This is aggroup.c in view mode; [Download] [Up]
/****************************************************************************
**
*A aggroup.c GAP source Thomas Bischops
*A & Frank Celler
**
*H @(#)$Id: aggroup.c,v 3.43 1993/10/07 14:33:39 martin Rel $
**
*Y Copyright 1990-1992, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany
**
** This file contains the functions which deal with aggroup and agwords
** on GAP level.
**
*H $Log: aggroup.c,v $
*H Revision 3.43 1993/10/07 14:33:39 martin
*H changed an expression which was too complicated for a compiler
*H
*H Revision 3.42 1993/09/27 11:59:06 martin
*H Improved the speed of 'AgFpGroup' (dramatically)
*H
*H Revision 3.41 1993/02/04 10:51:10 martin
*H changed to use new 'finfield' and 'plist' interface
*H
*H Revision 3.40 1993/01/04 11:21:57 fceller
*H changed 'DepthAgWord'
*H
*H Revision 3.39 1992/04/29 09:29:39 martin
*H changed a few things to silence GCC
*H
*H Revision 3.38 1992/04/28 10:30:50 martin
*H removed 'ulong' (IBM RS/6000 compilers complain)
*H
*H Revision 3.37 1992/04/07 20:24:44 martin
*H changed the author line
*H
*H Revision 3.36 1992/02/07 13:17:11 fceller
*H Initial GAP 3.1 release.
*H
*H Revision 3.0 1990/07/28 12:00:00 fceller
*H Initial release under RCS.
*/
#include "system.h" /** system dependent functions **/
#include "gasman.h" /** dynamic storage manager **/
#include "eval.h" /** evaluator main dispatcher **/
#include "scanner.h" /** 'Pr' is here **/
#include "idents.h" /** 'FindRecname' is here **/
#include "integer.h" /** arbitrary size integers **/
#include "list.h" /** 'IsList' is here **/
#include "plist.h" /* plain list package */
#include "finfield.h" /** finite field package **/
#include "word.h" /** swords live here **/
#include "agcollec.h" /** private definitions of this package **/
#include "aggroup.h" /** definitions of this package **/
/*--------------------------------------------------------------------------\
| Evaluator functions and friends |
\--------------------------------------------------------------------------*/
/****************************************************************************
**
*F EqAg( <hdL>, <hdR> ) . . . . . . . . . . tests if two agwords are equal
**
** Returns 'true' if the two agwords <hdL> and <hdR> are equal. Is called
** from the evaluator, so both operands are already evaluated.
*/
TypHandle EqAg( hdL, hdR )
TypHandle hdL, hdR;
{
TypSword * ptL, * ptR;
/** If the length of the agwords is different, return 'false'. *********/
if ( SIZE( hdL ) != SIZE( hdR ) )
return HdFalse;
/** Both agwords must be of the same group to be equal. ****************/
if ( *PTR( hdL ) != *PTR( hdR ) )
return HdFalse;
/** If both agwords are the identity, return 'true'. *******************/
if ( ISID_AW( hdL ) )
return HdTrue;
/** The agwords are of the same group and have the same length, check **/
/** their entries. **/
ptL = PTR_AW( hdL );
ptR = PTR_AW( hdR );
while ( *ptL != -1 )
if ( *( ptL++ ) != *( ptR++ ) )
return HdFalse;
/** All entries are equal. *********************************************/
return HdTrue;
}
/****************************************************************************
**
*F LtAg( <hdL>, <hdR> ) . . . . . . . . . . . . . . tests if <hdL> < <hdR>
**
** Is called from the evaluator, so both operands are already evaluated.
** Agwords are compared through lexical ordering relative to the composition
** series of the group.
**
** If the agwords are from different groups, the number of group generators
** and the group handles are compared.
*/
TypHandle LtAg( hdL, hdR )
TypHandle hdL, hdR;
{
TypSword * ptL, * ptR;
long i, lenR, lenL;
/** Both agwords must be of the same group to be compared. Otherwise **/
/** the group with the smaller number of generators is less. If both **/
/** groups have the same number of generators compare the handles. **/
if ( *PTR( hdL ) != *PTR( hdR ) )
{
if ( NUMBER_OF_GENS( *PTR( hdL ) ) < NUMBER_OF_GENS( *PTR( hdR ) ) )
return HdTrue;
if ( NUMBER_OF_GENS( *PTR( hdL ) ) > NUMBER_OF_GENS( *PTR( hdR ) ) )
return HdFalse;
if ( (long) *PTR( hdL ) < (long) *PTR( hdR ) )
return HdTrue;
else
return HdFalse;
}
/** If the right agword is the identity, return 'false'. ***************/
lenR = LEN_AW( hdR );
if ( lenR == 0 )
return HdFalse;
/** If the left agword is the identity, return 'true' ******************/
lenL = LEN_AW( hdL );
if ( lenL == 0 )
return HdTrue;
/** Run through the words. *********************************************/
ptL = PTR_AW( hdL );
ptR = PTR_AW( hdR );
for ( i = MIN( lenL, lenR ); i > 0; --i )
{
/** Generator number, lower one wins *******************************/
if ( *ptL != *ptR )
if ( *ptL < *ptR )
return HdFalse;
else
return HdTrue;
ptL++;
ptR++;
/** Exponent, higher number wins ***********************************/
if ( *ptL != *ptR )
if ( *ptL > *ptR )
return HdFalse;
else
return HdTrue;
ptL++;
ptR++;
}
/** One word is a subword of the other, the longer one wins. ***********/
return ( lenL < lenR ) ? HdTrue : HdFalse;
}
/****************************************************************************
**
*F EvAg( <hdWrd> ) . . . . . . . evaluates a normed word in a soluble group
**
** As with other constants evaluating normed words simply returns.
*/
TypHandle EvAg( hdWrd )
TypHandle hdWrd;
{
return hdWrd;
}
/****************************************************************************
**
*F ProdAg( <hdL>, <hdR> ) . . . . . . . . . . . . . evaluates <hdL> * <hdR>
**
** Computes the product of the two (already evaluated) agwords <hdL>, <hdR>.
*/
TypHandle ProdAg ( hdL, hdR )
TypHandle hdL, hdR;
{
TypHandle hd, hdAgGroup;
long nrL, nrR, i;
TypSword * pnew, * pold;
/** Check the groups of the agwords. ***********************************/
hdAgGroup = *PTR( hdL );
if ( hdAgGroup != *PTR( hdR ) )
return Error( "AgWord op: agwords have different groups", 0L, 0L );
/** One of the words is the idenity, return the other word. ************/
nrL = LEN_AW( hdL );
if ( nrL == 0 )
return hdR;
nrR = LEN_AW( hdR );
if ( nrR == 0 )
return hdL;
/** The last generator of the left agword is smaller than the first **/
/** generator of the right agword, the result is the concatenation **/
/** without calling the collect-routine. **/
if ( PTR_AW( hdL )[ 2 * ( nrL - 1 ) ] < PTR_AW( hdR )[ 0 ] )
{
hd = NewBag( T_AGWORD, (2*(nrL + nrR) + 1) * SIZE_SWORD + SIZE_HD );
/** Set the group. *************************************************/
*PTR( hd ) = hdAgGroup;
/** Copy the generators and exps of <hdL>, skip the endmarker. *****/
pold = PTR_AW( hdL );
pnew = PTR_AW( hd );
for( i = 2 * nrL; i > 0; --i )
*( pnew++ ) = *( pold++ );
/** Copy the generators and exponents of <hdL>, do not skip the **/
/** endmarker. **/
pold = PTR_AW( hdR );
for ( i = 2 * nrR + 1; i > 0; --i )
*( pnew++ ) = *( pold++ );
return hd;
}
/** We must collect the product. ***************************************/
Collect( 0, hdL, hdR );
/** Convert the exponent-vector on lhs to an agword and return. ********/
return AgWordAgExp( HD_COLLECT_EXPONENTS( hdAgGroup ), hdAgGroup );
}
/****************************************************************************
**
*F PowAgI( <hdL>, <hdR> ) . . . . . . . . . . . . . evaluates <hdL> ^ <hdR>
**
** Is called to compute agword <hdL> ^ <hdR> for an agword <hdL> and an
** integer <hdR>. 'PowAgI' called from the evaluator, so both operands are
** already evaluated.
*/
TypHandle PowAgI( hdL, hdR )
TypHandle hdL, hdR;
{
register long i, exp, pow, nr;
TypHandle hd, hdGrp, hd1;
TypSword * pt1, * pt2;
exp = HD_TO_INT( hdR );
hdGrp = *PTR( hdL );
/** If the agword is trivial, return it. *******************************/
nr = LEN_AW( hdL );
if ( nr == 0 )
return hdL;
/** If the exponent is trivial, return the identity. *******************/
if ( exp == 0 )
return HD_IDENTITY( hdGrp );
/** If the exponent is equal 1, return the agword. *********************/
if ( exp == 1 )
return hdL;
/** If the agword is a one-generator-word and the exponent is positiv **/
/** try to construct the word without collection. **/
if ( exp > 0 && nr == 1 )
{
hd = NewBag( T_AGWORD, SIZE( hdL ) );
* PTR( hd ) = hdGrp;
pt1 = PTR_AW( hd );
pt2 = PTR_AW( hdL );
*( pt1++ ) = *pt2 ;
*( pt1+1 ) = -1;
i = exp * *( pt2 + 1 );
/** Reduce the power if necessary. *********************************/
pow = INDICES( hdGrp )[ *pt2 ];
if ( i >= pow )
{
*pt1 = i % pow;
hd1 = POWERS( hdGrp )[ *pt2 ];
if ( *pt1 == 0 )
{
*( pt1-1 ) = -1;
Resize( hd, SIZE_HD + SIZE_SWORD );
}
if ( LEN_AW( hd1 ) )
hd = ProdAg( hd, PowAgI( hd1, INT_TO_HD( i / pow ) ) );
}
else
*pt1 = i;
return hd;
}
/** Divide et impera! **************************************************/
if ( exp == 2 )
return ProdAg( hdL, hdL );
else if ( exp == 3 )
return ProdAg( hdL, ProdAg( hdL, hdL ) );
else if ( exp > 0 )
{
if ( exp % 2 )
{
hd = PowAgI( hdL, INT_TO_HD( (exp - 1) / 2 ) );
return ProdAg( hdL, ProdAg( hd, hd ) );
}
else
{
hd = PowAgI( hdL, INT_TO_HD( exp / 2 ) );
return ProdAg( hd, hd );
}
}
else if ( exp == -1 )
return AgSolution( hdL, HD_IDENTITY( hdGrp ) );
else
{
hd = PowAgI( hdL, INT_TO_HD( -exp ) );
return AgSolution( hd, HD_IDENTITY( hdGrp ) );
}
}
/****************************************************************************
**
*F QuoAg( <hdL>, <hdR> ) . . . . . . . . . . . . . . evaluates <hdL> / <hdR>
**
** 'QuoAg' computes the quotient <hdL> / <hdR>, that is <hdL> * <hdR> ^ -1.
** It is called from the evulator, so both operands are already evaluated.
*/
TypHandle QuoAg( hdL, hdR )
TypHandle hdL, hdR;
{
return ProdAg( hdL, PowAgI( hdR, INT_TO_HD( -1 ) ) );
}
/****************************************************************************
**
*F ModAg( <hdL>, <hdR> ) . . . . . . . . . . . . . evaluates <hdL> mod <hdR>
**
** 'ModAg' expects two agwords a and b, solves the equation a * x = b and
** returns the agword x.
*/
TypHandle ModAg( hdL, hdR )
TypHandle hdL, hdR;
{
if ( *PTR( hdR ) != *PTR( hdL ) )
return Error( "AgWord op: agwords have different groups", 0L, 0L );
if ( ISID_AW( hdL ) )
return hdR;
return AgSolution( hdL, hdR );
}
/****************************************************************************
**
*F PowAgAg( <hdL>, <hdR> ) . . . . . . . . . . . . . evaluates <hdL> ^ <hdR>
**
** Computes the conjugation <hdL>^<hdR>, that is <hdR> ^ -1 * <hdL> * <hdR>.
** Is called from the evulator, so both operands are already evaluated.
*/
TypHandle PowAgAg( hdL, hdR )
TypHandle hdL, hdR;
{
if ( *PTR( hdL ) != *PTR( hdR ) )
return Error( "AgWord op: agwords have different groups", 0L, 0L );
if ( ISID_AW( hdL ) || ISID_AW( hdR ) )
return hdL;
/** Solve the equation <hdR> * x = <hdL> * <hdR>. **********************/
return AgSolution2( hdR, HD_IDENTITY( *PTR( hdL ) ), hdL, hdR );
}
/****************************************************************************
**
*F CommAg( <hdL>, <hdR> ) . . . . . evaluates the commutator of two agwords
**
** 'CommAg' compute the commutator of the evaluated two agwords <hdL> and
** <hdR>.
**
** If <USE_COMMS> one generator commutator will be evaluated using the entry
** 'COMMUTATORS' in the group record.
*/
TypHandle CommAg( hdL, hdR )
TypHandle hdL, hdR;
{
TypHandle hdC;
# if USE_COMMS
TypHandle hdId, hdGrp;
long nrL, nrR;
TypSword genL, genR;
# endif /*USE_COMMS*/
/** Check the groups of the agwords. ***********************************/
if ( *PTR( hdL ) != *PTR( hdR ) )
return Error( "AgWord op: agwords have different groups", 0L, 0L );
/** If one of the agwords is the identity, return the identity. ********/
# if USE_COMMS
nrL = LEN_AW( hdL );
if ( nrL == 0 )
return hdL;
nrR = LEN_AW( hdR );
if ( nrR == 0 )
return hdR;
# else /* ! USE_COMMS */
if ( ISID_AW( hdL ) )
return hdL;
if ( ISID_AW( hdR ) )
return hdR;
# endif /* USE_COMMS */
/** If both agwords have length 1 and exponent 1, we can use the **/
/** 'COMMUTATORS'. **/
# if USE_COMMS
hdGrp = *PTR( hdL );
if ( nrL == 1
&& nrR == 1
&& PTR_AW( hdL )[ 1 ] == 1 && PTR_AW( hdR )[ 1 ] == 1 )
{
hdId = HD_IDENTITY( hdGrp );
genL = PTR_AW( hdL )[ 0 ];
genR = PTR_AW( hdR )[ 0 ];
if ( genL < genR )
hdC = COMMUTATORS( hdGrp )[ IND( genR, genL ) ];
else if ( genL > genR )
hdC = COMMUTATORS( hdGrp )[ IND( genL, genR ) ];
else
hdC = hdId;
if ( hdC == hdId )
return hdId;
else
{
if ( genL < genR )
return PowAgI( hdC, INT_TO_HD( -1 ) );
else
return hdC;
}
}
# endif /* USE_COMMS */
/** Solve the equation <hdR> * <hdL> * x = <hdL> * <hdR>. *************/
return AgSolution2( hdR, hdL, hdL, hdR );
}
/****************************************************************************
**
*V CallsEqAg, TimeEqAg . . . . . . . . . . . calls of / used time in 'EqAg'
*V CallsLtAg, TimeLtAg . . . . . . . . . . . calls of / used time in 'LtAg'
*V CallsProdAg, TimeProdAg . . . . . . . . calls of / used time in 'ProdAg'
*V CallsQuoAg, TimeQuoAg . . . . . . . . . . calls of / used time in 'QuoAg'
*V CallsModAg, TimeModAg . . . . . . . . . . calls of / used time in 'ModAg'
*V CallsPowAgI, TimePowAgI . . . . . . . . calls of / used time in 'PowAgI'
*V CallsPowAgAg, TimePowAgAg . . . . . . . calls of / used time in 'PowAgAg'
*V CallsCommAg, TimeCommAg . . . . . . . . calls of / used time in 'CommAg'
*V RepTimes . . . . . . . . . . . . . . repeat evaluation <RepTimes> times
*F TEqAg . . . . . . . . . . . . . . . . . . . . . . . . . . profiler 'EqAg'
*F TLtAg . . . . . . . . . . . . . . . . . . . . . . . . . . profiler 'LtAg'
*F TProdAg . . . . . . . . . . . . . . . . . . . . . . . . profiler 'ProdAg'
*F TQuoAg . . . . . . . . . . . . . . . . . . . . . . . . profiler 'QuoAg'
*F TModAg . . . . . . . . . . . . . . . . . . . . . . . . profiler 'ModAg'
*F TPowAgI . . . . . . . . . . . . . . . . . . . . . . . . profiler 'PowAgI'
*F TPowAgAg . . . . . . . . . . . . . . . . . . . . . . profiler 'PowAgAg'
*F TCommAg . . . . . . . . . . . . . . . . . . . . . . . . profiler 'CommAg'
*/
#if AG_PROFILE
long TimeEqAg, TimeLtAg, TimeProdAg, TimeQuoAg;
long TimeModAg, TimePowAgI, TimePowAgAg, TimeCommAg;
long TimeSumAg, TimeDiffAg;
long CallsEqAg, CallsLtAg, CallsProdAg, CallsQuoAg;
long CallsModAg, CallsPowAgI, CallsPowAgAg, CallsCommAg;
long CallsSumAg, CallsDiffAg;
long RepTimes = 0;
TypHandle TEqAg P(( TypHandle, TypHandle ));
TypHandle TLtAg P(( TypHandle, TypHandle ));
TypHandle TProdAg P(( TypHandle, TypHandle ));
TypHandle TQuoAg P(( TypHandle, TypHandle ));
TypHandle TModAg P(( TypHandle, TypHandle ));
TypHandle TPowAgI P(( TypHandle, TypHandle ));
TypHandle TPowAgAg P(( TypHandle, TypHandle ));
TypHandle TCommAg P(( TypHandle, TypHandle ));
TypHandle TEqAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = EqAg( hdL, hdR );
TimeEqAg += ( SyTime() - time );
CallsEqAg++;
return hd;
}
TypHandle TLtAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = LtAg( hdL, hdR );
TimeLtAg += ( SyTime() - time );
CallsLtAg++;
return hd;
}
TypHandle TProdAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = ProdAg( hdL, hdR );
TimeProdAg += ( SyTime() - time );
CallsProdAg++;
return hd;
}
TypHandle TQuoAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = QuoAg( hdL, hdR );
TimeQuoAg += ( SyTime() - time );
CallsQuoAg++;
return hd;
}
TypHandle TModAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = ModAg( hdL, hdR );
TimeModAg += ( SyTime() - time );
CallsModAg++;
return hd;
}
TypHandle TPowAgI( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = PowAgI( hdL, hdR );
TimePowAgI += ( SyTime() - time );
CallsPowAgI++;
return hd;
}
TypHandle TPowAgAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = PowAgAg( hdL, hdR );
TimePowAgAg += ( SyTime() - time );
CallsPowAgAg++;
return hd;
}
TypHandle TCommAg( hdL, hdR )
TypHandle hdL, hdR;
{
unsigned long i, time;
TypHandle hd = 0;
time = SyTime();
for ( i = 0; i < RepTimes; i++ )
hd = CommAg( hdL, hdR );
TimeCommAg += ( SyTime() - time );
CallsCommAg++;
return hd;
}
#endif /* AG_PROFILE */
/*--------------------------------------------------------------------------\
| Various (internal) GAP-functions dealing with aggroups. |
\--------------------------------------------------------------------------*/
/****************************************************************************
**
*F FunDUMPLONG( <hdCall> ) . . . . . . . internal debug function 'DUMP_LONG'
*/
#if PRINT_AG | GROUP_REC
TypHandle FunDUMPLONG( hdCall )
TypHandle hdCall;
{
long i, * ptr;
TypHandle hdObj;
/** Check and evaluate the arguments. ******************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: DUMP_LONG( <obj> )", 0L, 0L );
hdObj = EVAL( PTR( hdCall )[ 1 ] );
if ( hdObj == HdVoid )
return Error( "DUMP_LONG: function must return a value.", 0L, 0L );
/** Dump the object as longs ***************************************/
ptr = (long*) PTR( hdObj );
for ( i = SIZE( hdObj ) - 1; i >= 0; i -= 4 )
Pr( "%d ", *ptr++, 0L );
Pr( "\n", 0L, 0L );
return HdVoid;
}
#endif /* PRINT_AG | GROUP_REC */
/****************************************************************************
**
*F GapAgGroup( <aggroup> ) . . . . . . . . . . . . . . . . GAP level aggroup
*/
TypHandle GapAgGroup ( hdGrp )
TypHandle hdGrp;
{
TypHandle hdRec, hdRn, hdList;
hdRec = NewBag( T_REC, 4 * SIZE_HD );
hdRn = FindRecname( "generators" );
PTR( hdRec )[ 0 ] = hdRn;
hdList = Copy( HD_GENERATORS( hdGrp ) );
PTR( hdRec )[ 1 ] = hdList;
hdRn = FindRecname( "identity" );
PTR( hdRec )[ 2 ] = hdRn;
PTR( hdRec )[ 3 ] = HD_IDENTITY( hdGrp );
return hdRec;
}
/****************************************************************************
**
*F FunAgFpGroup( <hdCall> ) . . . . . . . . . . . . . internal 'AgFpGroup'
**
** 'FunAgFpGroup' implements 'AgFpGroup( <record> )'.
**
** 'AgFpGroup' expects a record with the abstract generators in a list
** <record.generators> and the relators in abstract generators in a list
** <record.relations>.
**
** It allocates and initializes the internal group-record and returns
** "rec( generators = [a_1, ..., a_n] )", where a_i are the ag-generators.
*/
TypHandle FunAgFpGroup ( hdCall )
TypHandle hdCall;
{
TypHandle hdRec, hdGrp, hdLst, hdRn, hdGns, hdTmp;
TypHandle * ptRec, * ptEnd, * ptLst, * ptGns;
long len, i;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: AgGroupFpGroup( <F> )", 0L, 0L );
hdRec = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdRec ) != T_REC )
return Error( "usage: AgGroupFpGroup( <F> )", 0L, 0L );
/** Allocate the internal group-bag to store the group-informations. ***/
hdGrp = BlankAgGroup();
/** Find the list 'generators' in the input-record. ********************/
hdRn = FindRecname( "generators" );
ptRec = PTR( hdRec );
ptEnd = (TypHandle*) ( (char*) ptRec + SIZE( hdRec ) );
while ( ptRec < ptEnd && ptRec[ 0 ] != hdRn )
ptRec += 2;
if ( ptRec == ptEnd )
return Error( "AgGroupFpGroup: no '~.generators'.", 0L, 0L );
hdGns = ptRec[ 1 ];
if ( ! IsList( hdGns ) )
return Error( "AgGroupFpGroup: no list '~.generators'.", 0L, 0L );
len = HD_TO_INT( PTR( hdGns )[ 0 ] );
/** Copy the abstract generators of the words 'generators'. ************/
hdLst = NewBag( T_LIST, ( len + 1 ) * SIZE_HD );
PTR( hdLst )[ 0 ] = INT_TO_HD( len );
HD_WORDS( hdGrp ) = hdLst;
ptLst = PTR( hdLst );
ptGns = PTR( hdGns );
for ( i = len; i > 0; i-- )
{
hdTmp = ptGns[ i ];
if ( TYPE( hdTmp ) != T_WORD && TYPE( hdTmp ) != T_SWORD )
return Error( "%d. generator must be a word", i, 0L );
if ( TYPE( hdTmp ) == T_WORD )
{
if ( SIZE( hdTmp ) != SIZE_HD )
return Error( "%d. generator must have length 1", i, 0L );
ptLst[i] = PTR( hdTmp )[ 0 ];
}
else
{
if ( SIZE( hdTmp ) != SIZE_HD + 3 * SIZE_SWORD
|| PTR_AW( hdTmp )[ 1 ] != 1 )
{
return Error( "%d. generator must have length 1", i, 0L );
}
ptLst[i] = PTR( *PTR( hdTmp ) )[ PTR_AW( hdTmp )[0] + 1 ];
}
}
/** Set the <NUMBER_OF_GENERATORS>. ************************************/
HD_NUMBER_OF_GENS( hdGrp ) = INT_TO_HD( len );
/** Set <SAVE_EXPONENTS> and <COLLECT_EXPONENTS>. **********************/
hdLst = NewBag( T_AGEXP, SIZE_EXP * len );
HD_SAVE_EXPONENTS( hdGrp ) = hdLst;
hdLst = NewBag( T_AGEXP, SIZE_EXP * len );
HD_COLLECT_EXPONENTS( hdGrp ) = hdLst;
ClearCollectExponents( hdGrp );
hdLst = NewBag( T_AGEXP, SIZE_EXP * len );
HD_COLLECT_EXPONENTS_2( hdGrp ) = hdLst;
/** Set <GENERATORS> and <IDENTITY>. ***********************************/
SetGeneratorsAgGroup( hdGrp );
/** Check and enter the relations into the group bag. ******************/
if ( len > 0 )
ReadRelators( hdRec, hdGrp );
/** return GAP level aggroup record ************************************/
return GapAgGroup( hdGrp );
}
/****************************************************************************
**
*F FunSetCollectorAgWord( <hdCall> ) . . . . . internal 'SetCollectorAgWord'
**
** 'FunSetCollectorAgWord' implements
**
** 'SetCollectorAgWord( <g>, "single" )'
** 'SetCollectorAgWord( <g>, "triple"[, <bound>] )'
** 'SetCollectorAgWord( <g>, "qudrauple"[, <bound>] )'
** 'SetCollectorAgWord( <g>, "combinatorial" )'
**
** Most of the work is done in the corresponding 'Init....' functions. For
** example, 'InitCombinatorial' computes an central series, while the init
** routine 'InitQuadruple' computes the quadruple g_i^r ^ g_j^s. These
** routines change the collector-entries of the group record of <g>.
*/
TypHandle FunSetCollectorAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd, hdStr;
long i;
char * usage = "usage: SetCollectorAgWord( <g>, <name> )";
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) < 3 * SIZE_HD )
return Error( usage, 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
hdStr = EVAL( PTR( hdCall )[ 2 ] );
if ( TYPE( hdWrd ) != T_AGWORD || TYPE( hdStr ) != T_STRING )
return Error( usage, 0L, 0L );
/** Try to find the new collector <string> in 'Collectors.name'. ******/
for ( i = 0; i <= COMBI_COLLECTOR; i++ )
if ( ! SyStrcmp( Collectors[ i ].name, (char*) PTR( hdStr ) ) )
break;
/** As 'COMBI_COLL' has the highst number, we have not found the **/
/** collector if <i> > 'COMBI_COLL'. Raise an Error and print all **/
/** collector names. **/
if ( i > COMBI_COLLECTOR )
{
Pr( "#I Known collectors: ", 0L, 0L );
for ( i = 0; i < COMBI2_COLLECTOR; i++ )
Pr( "%2>%s%<,%< ", (long) Collectors[ i ].name, 0L );
Pr( "%2>%s%<.%<\n", (long)Collectors[COMBI2_COLLECTOR].name, 0L );
return Error( "Collector \"%s\" unkown", (long) PTR( hdStr ), 0L );
}
/** Call the init-routine for the collector. ***************************/
Collectors[ i ].init( hdCall, i );
return HdVoid;
}
/****************************************************************************
**
*F FunFactorAgWord( <hdCall> ) . . . . . . . . . . . internal 'FactorAgWord'
**
** 'FunFactorAgWord' implements 'FactorAgWord( <l>, <r> )'
**
** Return the homomorphic image of the agword <l> in the group of <r>.
**
** 'FunFactorAgWord' simply copies the word <l> upto the composition length
** which still lies in the group of <r>. The function does not check if
** is this operation forms a homomorphism, but an error is raised if the
** indices of the generators of the groups <l> and <r> are not equal.
*/
TypHandle FunFactorAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdL, hdR;
TypHandle hdGrpL, hdGrpR, hdWrd;
TypSword nrOld, nrNew;
TypSword i;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( "usage: FactorAgWord( <g> , <to> )", 0L, 0L );
hdL = EVAL( PTR( hdCall )[ 1 ] );
hdR = EVAL( PTR( hdCall )[ 2 ] );
if ( TYPE( hdL ) != T_AGWORD || TYPE( hdR ) != T_AGWORD )
return Error( "usage: FactorAgWord( <g> , <to> )", 0L, 0L );
/** Get the group of the agwords. **************************************/
hdGrpL = *PTR( hdL );
hdGrpR = *PTR( hdR );
/** Check the indices of the two aggroups. ***************************/
nrOld = NUMBER_OF_GENS( hdGrpL );
nrNew = NUMBER_OF_GENS( hdGrpR );
for ( i = MIN( nrOld, nrNew ) - 1; i >= 0; i-- )
if ( INDICES( hdGrpL )[ i ] != INDICES( hdGrpR )[ i ] )
return Error(
"FactorAgWord: groups have different indices (%d != %d)",
(long) INDICES( hdGrpL )[ i ],
(long) INDICES( hdGrpR )[ i ] );
/** Copy the word. Use only those generators with weight < <nrNew>. ****/
hdWrd = HeadAgWord( hdL, nrNew );
/** Change the group of this word. *************************************/
*PTR( hdWrd ) = hdGrpR;
return hdWrd;
}
/****************************************************************************
**
*F FactorAgGroup( <hdG>, <n> ) . . . . . . factor group of the group of <g>
*F FunFactorAgGroup( <hdCall> ) . . . . . . . . . internal 'FactorAgGroup'
**
** 'FunFactorAgGroup' implements 'FactorAgGroup( <g>, <i> )'
**
** 'FactorAgGroup' expects a agword <g> and the new number <i> of group
** generators. It then constructs the factorgroup of the group of the
** <g> and returns group-record which describes this factor group.
**
** Copy all information of the old group and initialize the same collector.
*/
TypHandle FactorAgGroup ( hdGrp, new )
TypHandle hdGrp;
long new;
{
TypHandle hdFac, hdLst, hdTmp, hdOld, hdNew;
long i, j, old;
old = NUMBER_OF_GENS( hdGrp );
new = MIN( new, old );
/** Allocate the internal group-bag to store factorgroup informations **/
hdFac = BlankAgGroup();
/** Set 'GENERATORS', 'IDENTITY', 'COLLECTOR' and 'NUMBER_OF_GENS'. ****/
HD_COLLECTOR( hdFac ) = HD_COLLECTOR( hdGrp );
HD_NUMBER_OF_GENS( hdFac ) = INT_TO_HD( new );
SetGeneratorsAgGroup( hdFac );
/** Set 'SAVE_EXPONENTS' and 'COLLECT_EXPONENTS' ***********************/
hdTmp = NewBag( T_AGEXP, SIZE_EXP * new );
HD_SAVE_EXPONENTS( hdFac ) = hdTmp;
hdTmp = NewBag( T_AGEXP, SIZE_EXP * new );
HD_COLLECT_EXPONENTS( hdFac ) = hdTmp;
ClearCollectExponents( hdFac );
hdTmp = NewBag( T_AGEXP, SIZE_EXP * new );
HD_COLLECT_EXPONENTS_2( hdFac ) = hdTmp;
/** Copy 'WORDS' and 'INDICES'. ****************************************/
hdLst = NewBag( T_LIST, ( new + 1 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( new );
HD_WORDS( hdFac ) = hdLst;
hdTmp = NewBag( T_INTPOS, new * sizeof( long ) );
HD_INDICES( hdFac ) = hdTmp;
for ( i = new - 1; i >= 0; i-- )
{
WORDS( hdFac )[ i ] = WORDS( hdGrp )[ i ];
INDICES( hdFac )[ i ] = INDICES( hdGrp )[ i ];
}
/** Transfer the 'POWERS' using 'HeadAgWord' ***************************/
hdLst = NewBag( T_LIST, ( new + 1 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( new );
HD_POWERS( hdFac ) = hdLst;
for ( i = new - 1; i >= 0; i-- )
{
hdTmp = HeadAgWord( POWERS( hdGrp )[ i ], new );
*PTR( hdTmp ) = hdFac;
PTR( hdLst )[i+1] = ISID_AW( hdTmp ) ? HD_IDENTITY( hdFac ) : hdTmp;
}
/** Compute the list of 'COMMUTATORS'. *********************************/
hdLst = NewBag( T_LIST, ( new * ( new - 1 ) / 2 + 1 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( new * ( new - 1 ) / 2 );
HD_COMMUTATORS( hdFac ) = hdLst;
for ( i = new * ( new - 1 ) / 2 - 1; i >= 0; i-- )
{
hdTmp = HeadAgWord( COMMUTATORS( hdGrp )[ i ], new );
*PTR( hdTmp ) = hdFac;
PTR( hdLst )[i+1] = ISID_AW( hdTmp ) ? HD_IDENTITY( hdFac ) : hdTmp;
}
/** Copy collector dependent parts of the record. **********************/
SaveAndClearCollector( hdFac );
switch( (int) COLLECTOR( hdFac ) )
{
case SINGLE_COLLECTOR:
SetAvecAgGroup( hdFac, 0, NUMBER_OF_GENS(hdFac)-1 );
hdLst = NewBag( T_LIST, ( new * (new-1)/2 + 1 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( new * ( new - 1 ) / 2 );
for ( i = new * ( new - 1 ) / 2 - 1; i >= 0; i-- )
{
hdTmp = HeadAgWord( CONJUGATES( hdGrp )[ i ], new );
*PTR( hdTmp ) = hdFac;
if ( ISID_AW( hdTmp ) )
PTR( hdLst )[ i + 1 ] = HD_IDENTITY( hdFac );
else
PTR( hdLst )[ i + 1 ] = hdTmp;
}
HD_CONJUGATES( hdFac ) = hdLst;
hdTmp = FindRecname( "conjugates" );
PTR( hdFac )[ NR_CONJUGATES - 1 ] = hdTmp;
break;
case TRIPLE_COLLECTOR:
case QUADR_COLLECTOR:
SetAvecAgGroup( hdFac, 0, NUMBER_OF_GENS(hdFac)-1 );
hdLst = NewBag( T_LIST, ( new * (new-1)/2 + 1 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( new * ( new - 1 ) / 2 );
HD_TRIPLES( hdFac ) = hdLst;
for ( i = new * ( new - 1 ) / 2 - 1; i >= 0; i-- )
{
hdTmp = TRIPLES( hdGrp )[ i ];
if ( hdTmp != 0 )
{
hdNew = NewBag( T_LIST, SIZE( hdTmp ) );
*PTR( hdNew ) = *PTR( hdTmp );
for ( j = 1; j < SIZE( hdTmp ) / SIZE_HD; j++ )
{
hdOld = HeadAgWord( PTR( hdTmp )[ j ], new );
*PTR( hdOld ) = hdFac;
PTR( hdNew )[ j ] = hdOld;
}
}
else
hdNew = 0;
TRIPLES( hdFac )[ i ] = hdNew;
}
HD_TUPLE_BOUND( hdFac ) = HD_TUPLE_BOUND( hdGrp );
hdTmp = FindRecname( "tupleBound" );
PTR( hdFac )[ NR_TUPLE_BOUND - 1 ] = hdTmp;
PTR(hdFac)[NR_TRIPLES-1] = PTR(hdGrp)[NR_TRIPLES-1];
break;
case LEE_COLLECTOR:
case COMBI_COLLECTOR:
case COMBI2_COLLECTOR:
SetCWeightsAgGroup( hdFac, HdVoid );
break;
}
/** Initialize the collection-stacks. **********************************/
SetStacksAgGroup( hdFac );
/** Allocate the output-record *****************************************/
return GapAgGroup( hdFac );
}
TypHandle FunFactorAgGroup ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd, hdGrp, hdInt;
long new;
char * usage = "usage: FactorAgGroup( <g>, <n> )";
/** Evalute and check the arguments. ***********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( usage, 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
hdInt = EVAL( PTR( hdCall )[ 2 ] );
if ( TYPE( hdInt ) != T_INT || TYPE( hdWrd ) != T_AGWORD )
return Error( usage, 0L, 0L );
hdGrp = *PTR( hdWrd );
new = HD_TO_INT( hdInt );
if ( new < 0 )
return Error( "FactorAgGroup: negative composition length", 0L, 0L );
/** 'FactorAgGroup' does all the work for use. *************************/
return FactorAgGroup( hdGrp, new );
}
/****************************************************************************
**
*F FunAgGroupRecord( <hdCall> ) . . . . . . . . . internal 'AgGroupRecord'
**
** 'FunAgGroupRec' implements 'AgGroupRecord( <g> )'.
**
** 'FunAgGroupRec' returns the internal group record of <g>.
**
** This function is only defined, if <GROUP_REC> is set. The entries 'AVEC',
** 'INDICES', 'CWEIGHTS' and 'CSERIES' can be decoded using 'DUMP_LONG'.
*/
#if GROUP_REC
TypHandle FunAgGroupRecord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd;
/** Evalute and check the arguments. *******************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: AgGroupRecord( <g> )", 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) != T_AGWORD )
return Error( "usage: AgGroupRecord( <g> )", 0L, 0L );
/** Return the internal group record. ******************************/
return *PTR( hdWrd );
}
#endif /* GROUP_REC */
/*--------------------------------------------------------------------------\
| Various (internal) GAP-functions dealing with agwords. |
\--------------------------------------------------------------------------*/
/****************************************************************************
**
*V HdRnSumAgWord . . . . . . . . . . . handle of 'SumAgWord' record name bag
*F SumAgWord( <P>, <v>, <w> ) . . . . . . . . . . sum of <v> and <w> in <P>
*F FunSumAgWord( <hdCall> ) . . . . . . . . . . . . . internal 'SumAgWord'
**
** 'FunSumAgWord' implements 'SumAgWord( <v>, <w> )'
**
** 'SumAgWord' returns the agword representing the sum of exponentvectors of
** the agwords <v> and <w>. The exponents are reduced modulo their relative
** order defined in <P>.
**
** If <v> or <w> are actual records which have an entry 'operations' which
** is a record and this record has an entry 'SumAgWord' which is a function,
** then this function is called with <v> and <w> as arguments. This function
** should then return the sum of <v> and <w>
*/
TypHandle HdRnSumAgWord, HdCallSumAgWord;
TypHandle SumAgWord ( hdP, hdV, hdW )
TypHandle hdP;
TypHandle hdV;
TypHandle hdW;
{
TypHandle hdSum = 0;
TypSword * ptSum, * ptV, * ptW;
long * ptIdx, len, nr, exp;
# if AG_PROFILE
unsigned long i, time = 0;
# endif
# if AG_PROFILE
if ( RepTimes > 0 )
CallsSumAg++;
# endif
if ( ISID_AW( hdV ) )
return hdW;
if ( ISID_AW( hdW ) )
return hdV;
/** Do we want to time ? ***********************************************/
# if AG_PROFILE
if ( RepTimes > 0 )
time = SyTime();
i = 0;
do
{
# endif
/** count the number of nontrivial exponents ***************************/
len = 0;
ptIdx = INDICES( hdP );
ptV = PTR_AW( hdV );
ptW = PTR_AW( hdW );
while ( * ptV != -1 && * ptW != -1 )
{
if ( * ptV < * ptW )
{
len++;
ptV += 2;
}
else if ( * ptV > * ptW )
{
len++;
ptW += 2;
}
else
{
nr = * ptV;
if ( ( * ++ptV + * ++ptW ) % ptIdx[ nr ] != 0 )
len++;
ptV++;
ptW++;
}
}
while ( * ptV != -1 )
{
len++;
ptV += 2;
}
while ( * ptW != -1 )
{
len++;
ptW += 2;
}
/** now do the same again, but copy the exponent vector ****************/
# if AG_PROFILE
if ( i == 0 )
# endif
hdSum = NewBag( T_AGWORD, SIZE_HD + ( 2 * len + 1 ) * SIZE_SWORD );
* PTR( hdSum ) = hdP;
ptSum = PTR_AW( hdSum );
ptV = PTR_AW( hdV );
ptW = PTR_AW( hdW );
ptIdx = INDICES( hdP );
while ( * ptV != -1 && * ptW != -1 )
{
if ( * ptV < * ptW )
{
* ptSum++ = * ptV++;
* ptSum++ = * ptV++;
}
else if ( * ptV > * ptW )
{
* ptSum++ = * ptW++;
* ptSum++ = * ptW++;
}
else
{
nr = * ptV;
exp = ( * ++ptV + * ++ptW ) % ptIdx[ nr ];
if ( exp != 0 )
{
* ptSum++ = nr;
* ptSum++ = exp;
}
ptV++;
ptW++;
}
}
while ( * ptV != -1 )
{
* ptSum++ = * ptV++;
* ptSum++ = * ptV++;
}
while ( * ptW != -1 )
{
* ptSum++ = * ptW++;
* ptSum++ = * ptW++;
}
* ptSum = -1;
/** return the word or repeat in order to time *************************/
# if AG_PROFILE
i++;
} while ( i < RepTimes );
if ( RepTimes > 0 )
TimeSumAg += ( SyTime() - time );
# endif
return hdSum;
}
TypHandle FunSumAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdV, hdW;
char * usage = "usage: SumAgWord( <v>, <w> )";
/** Evaluate and check the arguments ***********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( usage, 0L, 0L );
hdV = EVAL( PTR( hdCall )[ 1 ] );
hdW = EVAL( PTR( hdCall )[ 2 ] );
if ( TYPE( hdV ) != T_AGWORD || TYPE( hdW ) != T_AGWORD )
return EvalOop2( hdV, hdW, HdRnSumAgWord, usage );
/** Do they have the same aggroup ? ************************************/
if ( * PTR( hdV ) != * PTR( hdW ) )
return Error("<v> and <w> must have a common parent group", 0L, 0L);
return SumAgWord( *PTR( hdV ), hdV, hdW );
}
/****************************************************************************
**
*V HdRnDifferenceAgWord . . . handle of 'DifferenceAgWord' record name bag
*F DifferenceAgWord( <P>, <v>, <w> ) . . . . . . . difference of <v> and <w>
*F FunDifferenceAgWord( <hdCall> ) . . . . . . . internal 'DifferenceAgWord'
**
** 'FunDifferenceAgWord' implements 'DifferenceAgWord( <v>, <w> )'
**
** 'FunDifferenceAgWord' returns the agword representing the difference of
** exponent vectors of the agwords <v> and <w>. The exponents are reduced
** modulo their index.
**
** If <v> or <w> are actual records which have an entry 'operations' which
** is a record and this record has an entry 'DifferenceAgWord' which is a
** function, then this function is called with <v> and <w> as arguments.
** This function should then return the difference of <v> and <w>.
*/
TypHandle HdRnDifferenceAgWord;
TypHandle DifferenceAgWord ( hdP, hdV, hdW )
TypHandle hdP;
TypHandle hdV;
TypHandle hdW;
{
TypHandle hdDiff = 0;
TypSword * ptDiff, * ptV, * ptW;
long * ptIdx, len, nr, exp;
# if AG_PROFILE
unsigned long i, time = 0;
# endif
# if AG_PROFILE
CallsDiffAg++;
# endif
if ( ISID_AW( hdW ) )
return hdV;
/** Do we want to time ? ***********************************************/
# if AG_PROFILE
if ( RepTimes > 0 )
time = SyTime();
i = 0;
do
{
# endif
/** count the number of nonTrivial exponents ***************************/
len = 0;
ptIdx = INDICES( hdP );
ptV = PTR_AW( hdV );
ptW = PTR_AW( hdW );
while ( * ptV != -1 && * ptW != -1 )
{
if ( * ptV < * ptW )
{
len++;
ptV += 2;
}
else if ( * ptV > * ptW )
{
len++;
ptW += 2;
}
else
{
nr = * ptV;
if ( ( * ++ptV - *++ptW ) % ptIdx[ nr ] != 0 )
len++;
ptV++;
ptW++;
}
}
while ( * ptV != -1 )
{
len++;
ptV += 2;
}
while ( * ptW != -1 )
{
len++;
ptW += 2;
}
/** now do the same again, but copy the exponent vector ****************/
# if AG_PROFILE
if ( i == 0 )
# endif
hdDiff = NewBag( T_AGWORD, SIZE_HD + ( 2 * len + 1 ) * SIZE_SWORD );
* PTR( hdDiff ) = hdP;
ptDiff = PTR_AW( hdDiff );
ptV = PTR_AW( hdV );
ptW = PTR_AW( hdW );
ptIdx = INDICES( hdP );
while ( * ptV != -1 && * ptW != -1 )
{
if ( * ptV < * ptW )
{
* ptDiff++ = * ptV++;
* ptDiff++ = * ptV++;
}
else if ( * ptV > * ptW )
{
nr = * ptW;
* ptDiff++ = * ptW++;
* ptDiff++ = ptIdx[ nr ] - * ptW++;
}
else
{
nr = * ptV;
exp = ( * ++ptV - *++ptW ) % ptIdx[ nr ];
if ( exp < 0 )
exp += ptIdx[ nr ];
if ( exp != 0 )
{
* ptDiff++ = nr;
* ptDiff++ = exp;
}
ptV++;
ptW++;
}
}
while ( * ptV != -1 )
{
* ptDiff++ = * ptV++;
* ptDiff++ = * ptV++;
}
while ( * ptW != -1 )
{
nr = * ptW;
* ptDiff++ = * ptW++;
* ptDiff++ = ptIdx[ nr ] - * ptW++;
}
* ptDiff = -1;
/** return the word ****************************************************/
# if AG_PROFILE
i++;
} while ( i < RepTimes );
if ( RepTimes > 0 )
TimeDiffAg += ( SyTime() - time );
# endif
return hdDiff;
}
TypHandle FunDifferenceAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdV, hdW;
char * usage = "usage: DifferenceAgWord( <v>, <w> )";
/** Evaluate and check the arguments ***********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( usage, 0L, 0L );
hdV = EVAL( PTR( hdCall )[ 1 ] );
hdW = EVAL( PTR( hdCall )[ 2 ] );
if ( TYPE( hdV ) != T_AGWORD || TYPE( hdW ) != T_AGWORD )
return EvalOop2( hdV, hdW, HdRnDifferenceAgWord, usage );
/** Do they have the same aggroup ? ************************************/
if ( * PTR( hdV ) != * PTR( hdW ) )
return Error("<v> and <w> must have a common parent group", 0L, 0L);
return DifferenceAgWord( *PTR( hdV ), hdV, hdW );
}
/****************************************************************************
**
*V HdRnDepth . . . . . . . . . . . . . . . . . 'DepthAgWord' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunDepthAgWord( <hdCall> ) . . . . . . . . . . . internal 'DepthAgWord'
**
** 'FunDepthAgWord' implements 'DepthAgWord( <g> )'
**
** 'DepthAgWord' returns the depth of the element <g> with respect to the
** composition series of the group to which <g> belongs. If and only if <g>
** is the identity, the composition length plus one is returned.
**
** 'FunDepthAgWord' simply returns the number (actual the number plus 1, as
** the generators are numbered from 0 upto some n) of the first non-trivial
** generator in the word. As T_AGWORD are stored dense, the number is the
** first entry in the datafield of <g>.
**
** If <g> is actual a record which has an element 'operations' which is a
** record and this record has an entry 'DepthAgWord' which is a function,
** then this function is called with <g> as argument. This function should
** then return the depth of <g>.
*/
TypHandle HdRnDepth;
TypHandle FunDepthAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd;
char * usage = "usage: DepthAgWord( <g> )";
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( usage, 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
if ( *PTR_AW(hdWrd) == -1 )
return INT_TO_HD(NUMBER_OF_GENS(*PTR(hdWrd))+1);
else
return INT_TO_HD( *(PTR_AW(hdWrd))+1 );
}
/** Maybe <g> is a record which is simulating an agword. *************/
return EvalOop( hdWrd, HdRnDepth, usage );
}
/****************************************************************************
**
*V HdRnTailDepth . . . . . . . . . . . . . . . . 'TailDepth' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunTailDepthAgWord( <hdCall> ) . . . . . . . internal 'TailDepthAgWord'
**
** 'FunTailDepthAgWord' implements 'TailDepthAgWord( <g> )'
**
** 'TailDepthAgWord' returns the tail depth of the element <g> with respect
** to the composition series of the group to which <g> belongs. If and only
** if <g> is the identity, 0 is returned.
**
** 'TailDepthAgWord' simply returns the number (actual the number plus 1, as
** the generators are numbered from 0 upto some n) of the last non-trivial
** generator in the word. As T_AGWORD are stored dense, the number is the
** entry before the endmark in the datafield of <g>.
**
** If <g> is actual a record which has an element 'operations' which is a
** record and this record has an entry 'TailDepthAgWord' which is a
** function, then this function is called with <g> as argument. This
** function should then return the tail depth of <g>.
*/
TypHandle HdRnTailDepth;
TypHandle FunTailDepthAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd;
TypSword * ptWrd;
long sze;
char * usage = "usage: TailDepthAgWord( <g> )";
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( usage, 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
sze = SIZE( hdWrd );
if ( sze == SIZE_HD + SIZE_SWORD )
return INT_TO_HD( 0 );
else
{
ptWrd = (TypSword*)( (char*) PTR( hdWrd ) + sze );
return INT_TO_HD( ( ptWrd[ -3 ] + 1 ) );
}
}
/** Maybe <g> is a record which is simulating an agword. *************/
return EvalOop( hdWrd, HdRnTailDepth, usage );
}
/****************************************************************************
**
*V HdRnCentralWeight . . . . . . . . . . . . 'CentralWeight' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunCentralWeightAgWord( <hdCall> ) . . . internal 'CentralWeightAgWord'
**
** 'FunCentralWeightAgWord' implements 'CentralWeightAgWord( <g> )'.
**
** 'CentralWeightAgWord' returns the central weight of the element <g> with
** respect to the central series of the group to which <g> belongs. Of
** course this must be group, for which a combinatorial collector is known.
** (At least the entry 'CWEIGHTS' of this group must be bound)
**
** 'FunCentralWeightAgWord' simply returns the number stored at i.th entry
** of 'CWEIGHTS' where i is depths of <g>.
**
** If <g> is actual a record which has an entry 'operations' which is a
** record and this record has an entry 'CentralWeightAgWord' which is a
** unction, then this function is called with <g> as argument. The function
** function should then return the central weight of <g>.
*/
TypHandle HdRnCentralWeight;
TypHandle FunCentralWeightAgWord( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd, hdGrp;
/** Evalute and check the arguments. ***********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return( Error( "usage: CentralWeightAgWord( <g> )", 0L, 0L ) );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
/** <g> is really an agword, so check, that the group has a **/
/** combinatorial collector. **/
hdGrp = *PTR( hdWrd );
if ( COLLECTOR( hdGrp ) != COMBI_COLLECTOR
&& COLLECTOR( hdGrp ) != COMBI2_COLLECTOR
&& COLLECTOR( hdGrp ) != LEE_COLLECTOR )
{
return Error( "CentralWeightAgWord: needs a p-central-series",
0L, 0L );
}
if ( ISID_AW( hdWrd ) )
/** The identity has central weight 0. *************************/
return INT_TO_HD( 0 );
else
/** Return the weight.th entry of CWEIGHTS. As <g> is sparse **/
/** the first entry of the datafield is the weight of <g>, **/
/** use this as index to CWEIGHTS. **/
return INT_TO_HD( CWEIGHTS( hdGrp )[ *PTR_AW( hdWrd ) ] );
}
/** Maybe <g> is a record which is simulating an agword. Check this **/
/** using 'EvalOop'. **/
return EvalOop( hdWrd,
HdRnCentralWeight,
"usage: CentralWeightAgWord( <g> )" );
}
/****************************************************************************
**
*V HdRnLeadingExponent . . . . . . . . . . 'LeadingExponent' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunLeadingExponentAgWord( <hdCall> ) . internal 'LeadingExponentAgWord'
**
** 'FunLeadingExponentAgWord' implements 'LeadingExponentAgWord( <g> )'.
**
** 'LeadingExponentAgWord' returns the exponent of the first non-trivial
** generator of the element <g>. Iff <g> is the identity, 0 is returned.
**
** 'FunLeadingExponentAgWord' returns the second entry in the data area of
** <g>. As T_AGWORD are stored sparse, this is the exponent of the first
** non-trivial generator.
**
** If <g> is actual a record which has an element 'operations' which is a
** record and this record has an element 'LeadingExponentAgWord' which is a
** function, then this function is called with <g> as argument. This
** function should then return the leading exponent of <g>.
*/
TypHandle HdRnLeadingExponent;
TypHandle FunLeadingExponentAgWord( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: LeadingExponentAgWord( <g> )", 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
/** <agword> is really an agword, so return its second entry or **/
/** 0, if <agword> is the idenity. **/
if ( ! ISID_AW( hdWrd ) )
return INT_TO_HD( *( PTR_AW( hdWrd ) + 1 ) );
else
return INT_TO_HD( 0 );
}
/** Maybe <g> is a record which is simulating an agword. Check this **/
/** using the function 'EvalOop'. **/
return EvalOop( hdWrd, HdRnLeadingExponent,
"usage: LeadingExponent( <g> )" );
}
/****************************************************************************
**
*V HdRnReducedAgWord . . . . . . . . . . . 'ReducedAgWord' record name bag
*F FunReducedAgWord( <hdCall> ) . . . . . . . . . internal 'ReducedAgWord'
**
** 'FunReducedAgWord' implements 'ReducedAgWord( <l>, <r> )'
**
** 'ReducedAgWord( <l>, <r> )' expects two agwords of the same depth and
** returns <r> ^ i * <l> for an integer i, such that the returned word has
** a different weight than the agwords <l> and <r>.
**
** If one of <l> or <r> is actual a record which has an element 'operations'
** which is a record with an element 'ReducedAgWord' which is a function,
** then this function is called with <l> and <r> as arguments. The function
** should then return an agword as described above.
*/
TypHandle HdRnReducedAgWord;
TypHandle FunReducedAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdL, hdR;
TypHandle hdGrp;
unsigned long a, b, bb, i, q, order;
/** If <AG_PROFILE> is defined, we nedd a temporary handles as we **/
/** must use 'POW' instead of 'PowAg'. **/
# if AG_PROFILE
TypHandle hdTmp;
# endif /* AG_PROFILE */
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( "usage: ReducedAgWord( <l>, <r> )", 0L, 0L );
hdL = EVAL( PTR( hdCall )[1] );
hdR = EVAL( PTR( hdCall )[2] );
if ( TYPE( hdL ) == T_AGWORD && TYPE( hdR ) == T_AGWORD )
{
/** Both arguments are agwords, check that they are of the same **/
/** group and have the same weight. **/
hdGrp = *PTR( hdL );
if ( hdGrp != *PTR( hdR ) )
return Error( "ReducedAgWord: agwords are of different groups",
0L, 0L );
if ( ISID_AW( hdL ) || ISID_AW( hdR ) )
return Error( "ReducedAgWord: cannot reduce identity",
0L, 0L );
/** The first data area entry of <hdL>, <hdR> contains the number **/
/** of the first non-trivial generator, the weight of an agword **/
/** minus 1. **/
if ( *PTR_AW( hdL ) != *PTR_AW( hdR ) )
return Error( "ReducedAgWord: agwords have different depths",
0L, 0L );
/** The second data area entry of <hdL> and <hdR> contains the **/
/** exponents <a> and <b> of the first non-trivial generator. The **/
/** entry INDICES of the group-bag contains a list T_AGEXP, which **/
/** contains the orders of the composition factorgroups. For the **/
/** entry <order> at depth of <l>, all we need is a non-negative **/
/** number i, such that <b> * i = <a> modulo <order>. Then **/
/** <r> ^ ( - i ) * <l> **/
/** is the agword we want. **/
a = (unsigned long) *( PTR_AW( hdL ) + 1 );
b = (unsigned long) *( PTR_AW( hdR ) + 1 );
order = INDICES( hdGrp )[ *PTR_AW( hdL ) ];
/** If <b> = 1 or <order> = 3, then <i> = <a> * <b> as <b> * <b> **/
/** is 1. If <b> = <a>, then <i>=1. If <b> < <a> and <b> divides **/
/** <a>, then <i> = <a> / <b>. Otherwise <i> can be obtained by **/
/** <i> = <a> * <b> ^ ( <order> - 2 ), **/
/** as <order> should be a prime. **/
if ( b == 1 || order == 3 )
i = ( a * b ) % order;
else if ( b < a && a % b == 0 )
i = a / b;
else
{
/** Divide et impera! Compute the powers modulo <order>. *******/
i = a;
q = order - 2;
bb = b;
while ( q )
{
if ( q & 1 )
i = ( i * bb ) % order;
bb = ( bb * bb ) % order;
q = q / 2;
}
}
/** Check, if will can reduce the <l>. *****************************/
if ( ( b * i ) % order != a % order )
return Error( "ReducedAgWord: cannot reduce agword",0L,0L );
/** Create the handle for the exponent and return the word. ********/
# if AG_PROFILE
hdTmp = POW( hdR, INT_TO_HD( -(long) i ) );
return PROD( hdTmp, hdL );
# else /* ! AG_PROFILE */
return ProdAg( PowAgI( hdR, INT_TO_HD( -(long) i ) ),
hdL );
# endif /* AG_PROFILE */
}
/** Maybe at least one of the arguments is a record. Check this using **/
/** the function 'EvalOop2'. **/
return EvalOop2( hdL,
hdR,
HdRnReducedAgWord,
"usage: ReducedAgWord( <l>, <r> )" );
}
/****************************************************************************
**
*V HdRnNormalizeIgs . . . . . . . . . . . . 'NormalizeIgs' record name bag
*F FunNormalizeIgs( <igs> ) . . . . . . . . . . . . internal 'NormalizeIgs'
**
** This is an internal version of:
**
** NormalizeIgs := function( igs )
** local i, j, exp;
**
** # Normalize leading exponent to one.
** for i in [ 1 .. Length( igs ) ] do
** igs[ i ] := igs[ i ] ^ ( 1 / LeadingExponentAgWord( igs[ i ] )
** mod RelativeOrderAgWord( igs[ i ] ) );
** od;
**
** # Make zeros above the diagonale.
** for i in [ 1 .. Length( igs ) - 1 ] do
** for j in [ i + 1 .. Length( igs ) ] do
** exp := ExponentAgWord( igs[ i ], DepthAgWord( igs[ j ] ) );
** if exp <> 0 then
** exp := RelativeOrderAgWord( igs[ j ] ) - exp;
** igs[ i ] := igs[ i ] * igs[ j ] ^ exp;
** fi;
** od;
** od;
**
** end;
*/
TypHandle HdRnNormalizeIgs;
TypHandle FunNormalizeIgs ( hdCall )
TypHandle hdCall;
{
TypHandle hdIgs, hdTmp, hdOne, hdPos, hdWrd, hdGrp, hdOrd, hdIdx;
TypHandle hdExp;
TypExp * ptPos, * ptEnd;
TypSword * ptWrd;
long i, j, d, p;
char *usage = "usage: NormalizeIgs( <igs> )";
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( usage, 0L, 0L );
hdIgs = EVAL( PTR( hdCall )[ 1 ] );
if ( ! IsList( hdIgs ) )
return Error( usage, 0L, 0L );
if ( LEN_LIST( hdIgs ) == 0 )
return HdVoid;
hdTmp = ELM_PLIST( hdIgs, 1 );
if ( TYPE( hdTmp ) != T_AGWORD )
return EvalOopN( hdTmp, HdRnNormalizeIgs, hdCall, usage );
hdGrp = PTR( hdTmp )[ 0 ];
if ( LEN_LIST( hdIgs ) > NUMBER_OF_GENS( hdGrp ) )
return Error( usage, 0L, 0L );
hdIdx = HD_INDICES( hdGrp );
/** Get weights and positions, normalize leading exponent to one. ******/
hdOne = INT_TO_HD( 1 );
hdPos = HD_COLLECT_EXPONENTS_2( hdGrp );
ptPos = (TypExp*) PTR( hdPos );
ptEnd = (TypExp*)( (char*) ptPos + SIZE( hdPos ) );
while ( ptPos < ptEnd )
*ptPos++ = 0;
for ( i = LEN_LIST( hdIgs ); 0 < i; i-- )
{
hdWrd = ELM_PLIST( hdIgs, i );
if ( TYPE( hdWrd ) != T_AGWORD )
return Error( "%d.th element must be an ag word", i, 0L );
ptWrd = PTR_AW( hdWrd );
d = ptWrd[0];
if ( d == -1 )
return Error( "%d.th element is the identity", i, 0L );
( (TypExp*)PTR( hdPos ) )[ d ] = i;
hdExp = INT_TO_HD( ptWrd[1] );
hdOrd = INT_TO_HD( ( (long*) PTR( hdIdx ) )[ d ] );
hdExp = QUO( hdOne, hdExp );
hdExp = MOD( hdExp, hdOrd );
# if AG_PROFILE
hdWrd = POW( hdWrd, hdExp );
# else
hdWrd = PowAgI( hdWrd, hdExp );
# endif
SET_ELM_PLIST( hdIgs, i, hdWrd );
}
/** Make zeros above diagonale. ****************************************/
for ( i = LEN_LIST( hdIgs ) - 1; 0 < i; i-- )
{
hdWrd = ELM_PLIST( hdIgs, i );
j = 2;
while ( 1 )
{
ptWrd = PTR_AW( hdWrd );
d = ptWrd[j];
if ( d == -1 )
break;
p = ( (TypExp*) PTR( hdPos ) )[ d ];
if ( p != 0 )
{
hdExp = INT_TO_HD( ((long*)PTR(hdIdx))[d] - ptWrd[j+1] );
# ifdef AG_PROFILE
hdTmp = ELM_PLIST( hdIgs, p );
hdTmp = POW( hdTmp, hdExp );
hdWrd = PROD( hdWrd, hdTmp );
# else
hdTmp = PowAgI( ELM_PLIST( hdIgs, p ), hdExp );
hdWrd = ProdAg( hdWrd, hdTmp );
# endif
j = 0;
}
j += 2;
}
SET_ELM_PLIST( hdIgs, i, hdWrd );
}
return HdVoid;
}
/****************************************************************************
**
*V HdRnRelativeOrder . . . . . . . . . . . . 'RelativeOrder' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunRelativeOrderAgWord( <hdCall> ) . . . internal 'RelativeOrderAgWord'
**
** 'FunRelativeOrderAgWord' implements 'RelativeOrderAgWord( <g> )'
**
** 'RelativeOrderAgWord' returns the smallest non-negative integer i, such
** that <g> ^ i has a different depth than <g>. If <g> is the identity, 1 is
** returned.
**
** If <g> is not the identity, then the order of the composition factor of
** <g> can be used as i. The order can be found at the depth.th position
** in the array INDICES of the aggroup of <g>.
**
** If <g> is actual a record which has an element 'operations' which is a
** record and this record has an record element 'RelativeOrderAgWord' which
** is a function, then this function is called with <g> as argument. This
** function should then return the relative order of <g>.
*/
TypHandle HdRnRelativeOrder;
TypHandle FunRelativeOrderAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: RelativeOrderAgWord( <g> )", 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[1] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
/** If the length of <g> is zero, <g> is the identity and so one **/
/** is returned. Otherwise the first data field entry of <g> **/
/** contains the number of the first non-trivial generators. Get **/
/** the order of the composition factorgroup and return it. **/
if ( ISID_AW( hdWrd ) )
return INT_TO_HD( 1 );
else
return INT_TO_HD( INDICES( *PTR( hdWrd ) )[ *PTR_AW( hdWrd ) ] );
}
/** Maybe <g> is a record which is simulating an agword. Check this **/
/** using the function 'EvalOop'. **/
return EvalOop(hdWrd, HdRnRelativeOrder, "usage: RelativeOrder( <g> )");
}
/****************************************************************************
**
*V HdRnExponentAgWord . . . . . . . . . . 'ExponentAgWord' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunExponentAgWord( <hdCall> ) . . . . . . . . . internal 'ExponentAgWord'
**
** 'FunExponentAgWord' implements 'ExponentAgWord( <g>, <i> )'
**
** Let the aggroup of <g> be generated by <g_1, ...,g_n>. Then every element
** of this group can be written as
**
** g_1 ^ {e_1} * g_2 ^ {e_2} * ... * g_n ^ {e_n},
**
** where (e_1, ...,e_n) is the exponent vector. 'ExponentAgWord' returns
** e_<i> for <i> in {1 ... n}. An error is raised if <i> is no element of
** {1 ... n}.
**
** As the exponent vector is stored sparse, we must run through it and look
** for the generator <i>.
**
** If one of the arguments is actual a record which has an 'operations'
** element which is a record and this record has an element 'ExponentAgWord'
** which is a function, then this function is called with the given args.
** The function should then return the exponent.
*/
TypHandle HdRnExponentAgWord;
TypHandle FunExponentAgWord( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd, hdI;
TypSword * pt, * ptEnd;
long i;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( "usage: ExponentAgWord( <g> , <i> )",0L,0L );
hdWrd = EVAL( PTR( hdCall )[1] );
hdI = EVAL( PTR( hdCall )[2] );
if ( TYPE( hdWrd ) == T_AGWORD && TYPE( hdI ) == T_INT )
{
/** The arguments are really an agword and an integer. At first **/
/** make sure that <i> is greater 0. **/
i = HD_TO_INT( hdI ) - 1;
if ( i < 0 )
return Error("ExponentAgWord: bad generator number %d", i+1, 0L);
if ( i >= NUMBER_OF_GENS( *PTR( hdWrd ) ) )
return Error("ExponentAgWord: bad generator number %d", i+1, 0L);
/** Run through the sparse exponent vector and search for <i>, **/
/** skip the last entry, which is an end mark. **/
pt = PTR_AW( hdWrd );
ptEnd = pt + 2 * LEN_AW( hdWrd );
while ( pt < ptEnd )
{
if ( *pt == i )
return INT_TO_HD( (long) *( pt + 1 ) );
else if ( *pt > i )
return INT_TO_HD( 0 );
pt += 2;
}
return INT_TO_HD( 0 );
}
/** Maybe <g> or <i> is actual a record. Check this using 'EvalOop2'. **/
return EvalOop2( hdWrd, hdI,
HdRnExponentAgWord,
"usage: ExponentAgWord( <g> , <i> )" );
}
/****************************************************************************
**
*V HdRnExponentsAgWord . . . . . . . . . . 'ExponentsAgWord' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FFExponentsAgWord( <g>, <s>, <e>, <z> ) . . . . conversion into ff-vector
*F IntExponentsAgWord( <g>, <s>, <e> ) . . . . . conversion into int-vector
*F FunExponentsAgWord( <hdCall> ) . . . . . . . internal 'ExponentsAgWord'
**
** 'FunExponentsAgWord' implements three incarnations of 'ExponentsAgWord':
** 'ExponentsAgWord( <g> )'
** 'ExponentsAgWord( <g>, <s>, <e> )'
** 'ExponentsAgWord( <g>, <s>, <e>, <z> )'
**
** Let the aggroup of <g> be generated by <g_1,...,g_n>. Then every element
** of this group can be written as
**
** $g_1 ^ {e_1} * g_2 ^ {e_2} * ... * g_n ^ {e_n}$,
**
** where (e_1, ...,e_n) is the exponent vector. For <g> 'ExponentsAgWord'
** returns the exponent vector as list [e_1, ..., e_n]. In the first two
** incarnations the result is returned as 'T_VECTOR', in the third case the
** result is of type 'T_VECFFE'.
**
** As the exponent vector is stored sparse, we must convert it first.
**
** If <g> is actual a record which has an 'operations' element which
** is a record and this record has an entry 'ExponentsAgWord' which is a
** function, then this function is called with the given arguments. The
** function should then return the exponent list.
*/
TypHandle HdRnExponentsAgWord;
TypHandle IntExponentsAgWord ( hdWrd, s, e )
TypHandle hdWrd;
long s;
long e;
{
TypHandle hdLst;
TypHandle * ptLst;
TypSword * ptWrd, * ptEnd;
long i;
hdLst = NewBag( T_VECTOR, ( e - s + 2 ) * SIZE_HD );
*PTR( hdLst ) = INT_TO_HD( e - s + 1 );
ptLst = PTR( hdLst ) + 1;
for ( i = e - s; i >= 0; i-- )
ptLst[ i ] = INT_TO_HD( 0 );
/** Enter the exponents at the appropriate entries given by the **/
/** generator number. Internally we start with number 0 not 1! **/
ptWrd = PTR_AW( hdWrd );
ptEnd = ptWrd + 2 * LEN_AW( hdWrd );
s--;
e--;
/** Skip all generators less than <s> **********************************/
while ( ptWrd < ptEnd && ptWrd[ 0 ] < s )
ptWrd += 2;
while ( ptWrd < ptEnd && ptWrd[ 0 ] <= e )
{
ptLst[ ptWrd[ 0 ] - s ] = INT_TO_HD( ptWrd[ 1 ] );
ptWrd += 2;
}
return hdLst;
}
TypHandle FFExponentsAgWord ( hdWrd, s, e, hdZ )
TypHandle hdWrd;
long s;
long e;
TypHandle hdZ;
{
TypHandle hdLst;
TypSword * ptWrd, * ptEnd;
TypFFE * ptVec, * ff, l, r;
long i, ordFF;
/** Construct an null vector of the correct length *********************/
hdLst = NewBag( T_VECFFE, SIZE_HD + sizeof( TypFFE ) *( e - s + 1 ) );
*PTR( hdLst ) = *PTR( hdZ );
ff = (TypFFE*) PTR( FLD_FFE( hdZ ) );
ordFF = SIZE_FF( FLD_FFE( hdZ ) );
ptVec = (TypFFE*)( PTR( hdLst ) + 1 );
for ( i = e - s; i >= 0; i-- )
ptVec[ i ] = 0;
/** Enter the exponents at the appropriate entries given by the **/
/** generator number. Internally we start with number 0 not 1! **/
ptWrd = PTR_AW( hdWrd );
ptEnd = ptWrd + 2 * LEN_AW( hdWrd );
s--;
e--;
/** Skip all generators less than <s> **********************************/
while ( ptWrd < ptEnd && ptWrd[ 0 ] < s )
ptWrd += 2;
while ( ptWrd < ptEnd && ptWrd[ 0 ] <= e )
{
r = ( ptWrd[ 1 ] % ordFF + ordFF ) % ordFF;
if ( r == 0 )
l = 0;
else
for ( l = 1; 1 < r; r-- )
l = ( l == 0 ? 1 : ff[ l ] );
ptVec[ ptWrd[ 0 ] - s ] = l;
ptWrd += 2;
}
return hdLst;
}
TypHandle FunExponentsAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdWrd, hdGrp, hdS, hdE, hdZ;
long s, e;
char * usage = "usage: ExponentsAgWord( <g>, <s>, <e>, <z> )";
/** Evluate and check the arguments. ***********************************/
if ( SIZE( hdCall ) < 2 * SIZE_HD
|| SIZE( hdCall ) > 5 * SIZE_HD
|| SIZE( hdCall ) == 3 * SIZE_HD )
{
return Error( usage, 0L, 0L );
}
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
/** Is <hdWrd> a record mimincing an agword ? **************************/
if ( TYPE( hdWrd ) == T_REC )
return EvalOopN( hdWrd, HdRnExponentsAgWord, hdCall, usage );
if ( TYPE( hdWrd ) != T_AGWORD )
return Error( usage, 0L, 0L );
/** Get or construct <s> and <e>. **************************************/
hdGrp = * PTR( hdWrd );
if ( SIZE( hdCall ) == 2 * SIZE_HD )
{
s = 1;
e = NUMBER_OF_GENS( hdGrp );
}
else
{
hdS = EVAL( PTR( hdCall )[ 2 ] );
hdE = EVAL( PTR( hdCall )[ 3 ] );
if ( TYPE( hdS ) != T_INT || TYPE( hdE ) != T_INT )
return Error( usage, 0L, 0L );
s = HD_TO_INT( hdS );
e = HD_TO_INT( hdE );
if ( 1 > s || s > e )
{
return Error( "ExponentsAgWord: needs 0 less <s> not greater <e>",
0L, 0L );
}
if ( e > NUMBER_OF_GENS( hdGrp ) )
{
return Error( "ExponentsAgWord: <e> must not greater than %d",
(long) NUMBER_OF_GENS( hdGrp ), 0L );
}
}
if ( SIZE( hdCall ) != 5 * SIZE_HD )
{
return IntExponentsAgWord( hdWrd, s, e );
}
else
{
/** Get the one of the field ***************************************/
hdZ = EVAL( PTR( hdCall )[ 4 ] );
if ( TYPE( hdZ ) != T_FFE )
return Error( usage, 0L, 0L );
return FFExponentsAgWord( hdWrd, s, e, hdZ );
}
}
/****************************************************************************
**
*V HdRnInformationAgWord . . . . . . . . 'InformationAgWord' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunInformationAgWord( <hdcall> ) . . . . . internal 'InformationAgWord'
**
** 'FunInformationAgWord' implements 'InformationAgWord( <g> )'
**
** 'InformationAgWord' returns a record with components
** 'generators' list of group generators
** 'names' list of names of the group generators
** 'powers' list of rhs of powers
** 'commutators' list of rhs of commutators
** 'indices' list of indices
** 'collector' name of the collector
** 'tupleBound' TUPLE_BOUND, if present.
**
** If <g> is actual a record which has an 'operations' element which
** is a record and this record has an entry 'InformationAgWord' which is a
** function, then this function is called with the given argument. This
** function should then return the informations.
*/
TypHandle HdRnInformationAgWord;
TypHandle FunInformationAgWord( hdCall )
TypHandle hdCall;
{
TypHandle hdGrp, hdWrd;
TypHandle hdRec, hdTmp;
TypHandle hd;
long i, len;
char * str;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: InformationAgWord( <g> )", 0L, 0L );
hdWrd = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdWrd ) == T_AGWORD )
{
/** <g> is really an agword, so construct a record with all the **/
/** informations. **/
hdGrp = *PTR( hdWrd );
hdRec = NewBag( T_REC, 8 * SIZE_HD );
len = NUMBER_OF_GENS( hdGrp );
/** Allocate an entry 'generators' in <hdRec> and bind a copy of **/
/** the list of the group generator to this entry. **/
PTR( hdRec )[ 0 ] = FindRecname( "generators" );
hdTmp = Copy( HD_GENERATORS( hdGrp ) );
PTR( hdRec )[ 1 ] = hdTmp;
/** Allocate an entry 'indices' in <hdRec> and bind a list of the **/
/** orders of the composition factor group to it. **/
PTR( hdRec )[ 2 ] = FindRecname( "indices" );
hdTmp = NewBag( T_LIST, ( len + 1 ) * SIZE_HD );
*PTR( hdTmp ) = INT_TO_HD( len );
/** Store the orders in this list. The orders can be found at **/
/** the <i>.th position in INDICES( <hdGrp> )'. **/
for ( i = len - 1; i >= 0; i-- )
PTR( hdTmp )[ i + 1 ] = INT_TO_HD( INDICES( hdGrp )[ i ] );
PTR( hdRec )[ 3 ] = hdTmp;
/** Allocate an entry 'names' in <hdRec> and bind a list of the **/
/** names of the generators to it. **/
PTR( hdRec )[ 4 ] = FindRecname( "names" );
hdTmp = NewBag( T_LIST, ( len + 1 ) * SIZE_HD );
*PTR( hdTmp ) = INT_TO_HD( len );
for ( i = len -1; i >= 0; i-- )
{
str = NAME_AW( hdGrp, i );
/** Copy the name, rember we need one more byte for the end. ***/
hd = NewBag( T_STRING, SyStrlen( str ) + 1 );
*( (char*) PTR( hd ) ) = '\0';
SyStrncat( (char*) PTR( hd ), str, SyStrlen( str ) );
PTR( hdTmp )[ i + 1 ] = hd;
}
PTR( hdRec )[ 5 ] = hdTmp;
/** Allocate an entry 'collector' in <hdRec> and bind the name of **/
/** the collector of <hdGrp> to this entry as described in **/
/** 'CollectorNames'. **/
hdTmp = FindRecname( "collector" );
PTR( hdRec )[ 6 ] = hdTmp;
/** Copy the name of 'CollectorNames'. If the number is higher **/
/** than 'COMBI_COLL' something has gone terrible wrong, as this **/
/** should be the highest collector number. **/
if ( COLLECTOR( hdGrp ) > COMBI_COLLECTOR )
return Error( "Corrupted group bag, collector = %d",
(long) COLLECTOR( hdGrp ), 0L );
str = Collectors[ COLLECTOR( hdGrp ) ].name;
/** Do the copy promised above, bind the string to <hdRec>. ********/
hd = NewBag( T_STRING, SyStrlen( str ) + 1 );
*( (char*) PTR( hd ) ) = '\0';
SyStrncat( (char*) PTR( hd ), str, SyStrlen( str ) );
PTR( hdRec )[ 7 ] = hd;
/** Some collector have a upper bound for the stored triples and **/
/** the like. Upto now the "triple" and "quadruple" collector **/
/** have this bound. For these collector allocate an element **/
/** 'tupleBound' in <hdRec> and bind the number to this entry. **/
if ( *PTR( hdWrd ) )
switch ( (int) COLLECTOR( hdGrp ) )
{
case TRIPLE_COLLECTOR:
case QUADR_COLLECTOR:
Resize( hdRec, 10 * SIZE_HD );
PTR( hdRec )[ 8 ] = FindRecname( "tupleBound" );
PTR( hdRec )[ 9 ] = INT_TO_HD(TUPLE_BOUND(hdGrp));
break;
}
return hdRec;
}
/** Maybe <agword> is a record faking an agword. Check this using the **/
/** function 'EvalOop'. **/
return EvalOop( hdWrd,
HdRnInformationAgWord,
"usage: InformationAgWord( <g> )" );
}
/****************************************************************************
**
*V HdRnIsAgWord . . . . . . . . . . . . . . . . 'IsAgWord' record name bag
*V HdCallSumAgWord . . . . . . . . . . . . . . . . . call to record function
*F FunIsAgWord( <hdCall> ) . . . . . . . . . . . . . . . internal 'IsAgWord'
**
** 'FunIsAgWord' implements 'IsAgWord( <obj> )'
**
** 'IsAgWord' returns 'true' if and only if the object <obj> is an agword
** and 'false' otherwise. It may cause an error if <obj> is an unbound
** variable.
**
** If <obj> is actual a record which has an element 'operations' which
** is a record and this record has an element 'IsAgWord' which is a
** function, then this function is called with <obj> as argument. This
** function should then return the 'true' or 'false'.
*/
TypHandle HdRnIsAgWord;
TypHandle FunIsAgWord( hdCall )
TypHandle hdCall;
{
TypHandle hdObj, hdTmp;
TypHandle * ptRec, * ptEnd;
TypHandle hdOp;
extern TypHandle HdRnOp;
extern TypHandle HdCallOop1;
/** Evaluate and check the argument. ***********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD )
return Error( "usage: IsAgWord( <obj> )", 0L, 0L );
hdObj = EVAL( PTR( hdCall )[ 1 ] );
if ( hdObj == HdVoid )
return Error( "IsAgWord: function must return a value", 0L, 0L );
/** Return 'true' if <obj> is an agword and 'false' if <obj> is no **/
/** agword and no record. If <obj> is a record check if <obj> has a **/
/** 'operation.IsAgWord' entry, which is a function. **/
if ( TYPE( hdObj ) == T_AGWORD )
return HdTrue;
if ( TYPE( hdObj ) != T_REC )
return HdFalse;
ptRec = PTR( hdObj );
ptEnd = (TypHandle*) ( (char*) ptRec + SIZE( hdObj ) );
while ( ptRec < ptEnd && ptRec[ 0 ] != HdRnOp )
ptRec += 2;
/** If a record 'operations' was found, look for <HdRnIsAgWord>. *******/
if ( ptRec == ptEnd || TYPE( ptRec[ 1 ] ) != T_REC ) goto l1;
hdOp = ptRec[ 1 ];
ptRec = PTR( hdOp );
ptEnd = (TypHandle*) ( (char*) ptRec + SIZE( hdOp ) );
while ( ptRec < ptEnd && ptRec[ 0 ] != HdRnIsAgWord )
ptRec += 2;
/** If it was found and is function, then apply it to <hdOb>. **********/
if ( ptRec == ptEnd )
goto l1;
PTR( HdCallOop1 )[ 0 ] = ptRec[ 1 ];
PTR( HdCallOop1 )[ 1 ] = hdObj;
hdTmp = EVAL( HdCallOop1 );
PTR( HdCallOop1 )[ 0 ] = 0;
PTR( HdCallOop1 )[ 1 ] = 0;
return hdTmp;
l1:
return HdFalse;
}
/****************************************************************************
**
*V HdRnIsCompatibleAgWord . . . . . . 'IsCompatibleAgWord' record name bag
*F FunIsCompatibleAgWord( <hdCall> ) . . . . . internal 'IsCompatibleAgWord'
**
** 'FunIsCompatibleAgWord' implements 'IsCompatibleAgWord( <a>, <b> )'
*/
TypHandle HdRnIsCompatibleAgWord;
TypHandle FunIsCompatibleAgWord ( hdCall )
TypHandle hdCall;
{
TypHandle hdA, hdB;
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 3 * SIZE_HD )
return Error( "usage: IsCompatibleAgWord( <g> , <h> )", 0L, 0L );
hdA = EVAL( PTR( hdCall )[ 1 ] );
hdB = EVAL( PTR( hdCall )[ 2 ] );
/** Check if both are ag words and have the same group. ****************/
if ( TYPE( hdA ) == T_AGWORD )
{
if ( TYPE( hdB ) == T_AGWORD )
return ( *PTR( hdA ) == *PTR( hdB ) ) ? HdTrue : HdFalse;
else
return HdFalse;
}
else
{
if ( TYPE( hdB ) == T_AGWORD )
return HdFalse;
else
return EvalOop2( hdA, hdB, HdRnIsCompatibleAgWord,
"<a> or <b> must be an ag word" );
}
}
/****************************************************************************
**
*F FunAgProfile( <hdCall> ) . . . . . . . . internal 'AgProfile( [<int>] )'
**
** AgProfile( <nr> ) . . . . . . . . . . . . Start/Stop profiling collection
** AgProfile( ) . . . . . . . . . . . . . . . . . . . Show collection time
**
** 'AgProfile' starts the profiling if <nr> > 0. In that case the evaluator
** function is called <nr> times. If <nr> = 0 profiling is stop. The second
** function call shows the timing. This function is only installed, if
** <AG_PROFILE> is defined. In order to avoid overhead the functions are
** timed directly, without using a table or something simelar.
*/
#if AG_PROFILE
TypHandle FunAgProfile ( hdCall )
TypHandle hdCall;
{
TypHandle hdInt;
/** Evaluate and check the arguments. *******************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD && SIZE( hdCall ) != SIZE_HD )
return Error( "usage: AgProfile( <int> ) or AgProfile()",
0L, 0L );
if ( SIZE( hdCall ) == SIZE_HD )
{
if ( RepTimes <= 0 )
{
/** User must start profiling first. **************************/
Pr( "No ag-profiling information, start profiling", 0L, 0L );
Pr( " with 'AgProfile( <int> )'\n", 0L, 0L );
return HdVoid;
}
/** Show the profile. ********************************************/
Pr( "function calls time time/call\n", 0L, 0L );
Pr( "--------------------------------------------\n", 0L, 0L );
if ( CallsProdAg > 0 )
{
Pr( "ProdAg %10d %10d", CallsProdAg, TimeProdAg/RepTimes );
Pr( " %10d\n", TimeProdAg/RepTimes / CallsProdAg, 0L );
}
if ( CallsQuoAg > 0 )
{
Pr( "QuoAg %10d %10d", CallsQuoAg, TimeQuoAg/RepTimes );
Pr( " %10d\n", TimeQuoAg/RepTimes / CallsQuoAg, 0L );
}
if ( CallsPowAgI > 0 )
{
Pr( "PowAgI %10d %10d", CallsPowAgI, TimePowAgI/RepTimes );
Pr( " %10d\n", TimePowAgI/RepTimes / CallsPowAgI, 0L );
}
if ( CallsPowAgAg > 0 )
{
Pr( "PowAgAg %10d %10d", CallsPowAgAg, TimePowAgAg/RepTimes );
Pr( " %10d\n", TimePowAgAg/RepTimes / CallsPowAgAg, 0L );
}
if ( CallsModAg > 0 )
{
Pr( "ModAg %10d %10d", CallsModAg, TimeModAg/RepTimes );
Pr( " %10d\n", TimeModAg/RepTimes / CallsModAg, 0L );
}
if ( CallsCommAg > 0 )
{
Pr( "CommAg %10d %10d", CallsCommAg, TimeCommAg/RepTimes );
Pr( " %10d\n", TimeCommAg/RepTimes / CallsCommAg, 0L );
}
if ( CallsLtAg > 0 )
{
Pr( "LtAg %10d %10d", CallsLtAg, TimeLtAg/RepTimes );
Pr( " %10d\n", TimeLtAg/RepTimes / CallsLtAg, 0L );
}
if ( CallsEqAg > 0 )
{
Pr( "EqAg %10d %10d", CallsEqAg, TimeEqAg/RepTimes );
Pr( " %10d\n", TimeEqAg/RepTimes / CallsEqAg, 0L );
}
if ( CallsSumAg > 0 )
{
Pr( "SumAg %10d %10d", CallsSumAg, TimeSumAg/RepTimes );
Pr( " %10d\n", TimeSumAg/RepTimes / CallsSumAg, 0L );
}
if ( CallsDiffAg > 0 )
{
Pr( "DiffAg %10d %10d", CallsSumAg, TimeDiffAg/RepTimes );
Pr( " %10d\n", TimeDiffAg/RepTimes / CallsDiffAg, 0L );
}
Pr( "--------------------------------------------\n", 0L, 0L );
Pr( "Evaluator functions repeated %d times.\n", RepTimes, 0L );
return HdVoid;
}
else
{
/** Start profiling. *********************************************/
hdInt = EVAL( PTR( hdCall )[ 1 ] );
if ( TYPE( hdInt ) != T_INT )
return( Error( "usage: AgProfile( [<int>] )", 0L, 0L ) );
RepTimes = HD_TO_INT( hdInt );
if ( RepTimes > 0 )
{
/** Reset the variables. **************************************/
CallsEqAg = TimeEqAg = 0;
CallsLtAg = TimeLtAg = 0;
CallsProdAg = TimeProdAg = 0;
CallsQuoAg = TimeQuoAg = 0;
CallsModAg = TimeModAg = 0;
CallsPowAgI = TimePowAgI = 0;
CallsPowAgAg = TimePowAgAg = 0;
CallsDiffAg = TimeDiffAg = 0;
CallsSumAg = TimeSumAg = 0;
/** Install the profiler functions. ***************************/
TabEq [ T_AGWORD ][ T_AGWORD ] = TEqAg;
TabLt [ T_AGWORD ][ T_AGWORD ] = TLtAg;
TabProd[ T_AGWORD ][ T_AGWORD ] = TProdAg;
TabQuo [ T_AGWORD ][ T_AGWORD ] = TQuoAg;
TabMod [ T_AGWORD ][ T_AGWORD ] = TModAg;
TabPow [ T_AGWORD ][ T_INT ] = TPowAgI;
TabPow [ T_AGWORD ][ T_AGWORD ] = TPowAgAg;
TabComm[ T_AGWORD ][ T_AGWORD ] = TCommAg;
return HdVoid;
}
else
{
RepTimes = 0;
/** Remove the profiler funtions. *****************************/
TabEq [ T_AGWORD ][ T_AGWORD ] = EqAg;
TabLt [ T_AGWORD ][ T_AGWORD ] = LtAg;
TabProd[ T_AGWORD ][ T_AGWORD ] = ProdAg;
TabQuo [ T_AGWORD ][ T_AGWORD ] = QuoAg;
TabMod [ T_AGWORD ][ T_AGWORD ] = ModAg;
TabPow [ T_AGWORD ][ T_INT ] = PowAgI;
TabPow [ T_AGWORD ][ T_AGWORD ] = PowAgAg;
TabComm[ T_AGWORD ][ T_AGWORD ] = CommAg;
return HdVoid;
}
}
}
#endif
/****************************************************************************
**
*V HdCPS . . . . . . . . . . . . . . . . . . . . . . . collector point stack
*V HdCPL . . . . . . . . . . . . . . . . . . . . . . . . . collector profile
*V HdCPC . . . . . . . . . . . . . . . . . . . . . . . . . collector counts
*V CPN . . . . . . . . . . . . . . . . . . . . . . . collector profile point
*V CPP . . . . . . . . . . . . . . . . . . . . . . collector profile started
*F FunCollectorProfile( <hdCall> ) . . . . . . . internal 'CollectorProfile'
**
** CollectorProfile( true ) . . . . . . . . . . . start collector profiling
** CollectorProfile( false ) . . . . . . . . . . . stop collector profiling
** CollectorProfile() . . . . . . . . . . . . . . . show collector profile
** CollectorProfile( <n> ) . . . . . . . . . . . . . . . set collector point
** CollectorProfile( 0 ) . . . . . . . . . . . . . . . clear collector point
*/
#if AG_PROFILE
TypHandle HdCPS, HdCPL, HdCPC;
boolean CPP = FALSE;
long CPN = 1;
TypHandle FunCollectorProfile ( hdCall )
TypHandle hdCall;
{
TypHandle hdA = 0;
long i, j;
char * usage = "usage: CollectorProfile( ... )";
/** Evaluate and check the arguments. **********************************/
if ( SIZE( hdCall ) != 2 * SIZE_HD && SIZE( hdCall ) != SIZE_HD )
return Error( usage, 0L, 0L );
if ( SIZE( hdCall ) == 2 * SIZE_HD )
hdA = EVAL( PTR( hdCall )[ 1 ] );
if ( SIZE( hdCall ) == SIZE_HD )
{
Pr( "pnt calls time time/call\n", 0L, 0L );
Pr( "-----------------------------------\n", 0L, 0L );
for ( i = 1; i <= LEN_LIST( HdCPL ); i++ )
{
long t, c;
t = HD_TO_INT( ELM_PLIST( HdCPL, i ) );
c = HD_TO_INT( ELM_PLIST( HdCPC, i ) );
if ( c == 0 )
continue;
Pr( "%3d: %6d ", i, c );
Pr( "%10d %8d\n", t, t/c );
}
Pr( "\nProfile point %d, profiling %sactive\n", CPN,
(long)( (CPP) ? "" : "in" ) );
return HdVoid;
}
else if ( TYPE( hdA ) == T_INT )
{
j = HD_TO_INT( hdA );
if ( j < 0 )
return Error( "<n> must be nonnegative", 0L, 0L);
else if ( j == 0 )
{
if ( LEN_LIST( HdCPS ) == 0 )
return Error( "no collector point set", 0L, 0L );
CPN = HD_TO_INT( ELM_PLIST( HdCPS, LEN_LIST( HdCPS ) ) );
PTR( HdCPS )[ 0 ] = INT_TO_HD( LEN_LIST( HdCPS ) - 1 );
return HdVoid;
}
else
{
if ( j > LEN_LIST( HdCPL ) )
{
Resize( HdCPL, ( j + 1 ) * SIZE_HD );
Resize( HdCPC, ( j + 1 ) * SIZE_HD );
for ( i = LEN_LIST( HdCPL ) + 1; i <= j; i++ )
{
PTR( HdCPL )[ i ] = INT_TO_HD( 0 );
PTR( HdCPC )[ i ] = INT_TO_HD( 0 );
}
PTR( HdCPL )[ 0 ] = INT_TO_HD( j );
PTR( HdCPC )[ 0 ] = INT_TO_HD( j );
}
Resize( HdCPS, ( LEN_LIST( HdCPS ) + 2 ) * SIZE_HD );
PTR( HdCPS )[ 0 ] = INT_TO_HD( LEN_LIST( HdCPS ) + 1 );
PTR( HdCPS )[ LEN_LIST( HdCPS ) ] = INT_TO_HD( CPN );
CPN = j;
return HdVoid;
}
}
else if ( TYPE( hdA ) == T_BOOL )
{
if ( hdA == HdTrue )
{
CPP = TRUE;
CPN = 1;
Resize( HdCPL, 2 * SIZE_HD );
Resize( HdCPC, 2 * SIZE_HD );
PTR( HdCPL )[ 0 ] = INT_TO_HD( 1 );
PTR( HdCPL )[ 1 ] = INT_TO_HD( 0 );
PTR( HdCPC )[ 0 ] = INT_TO_HD( 1 );
PTR( HdCPC )[ 1 ] = INT_TO_HD( 0 );
Resize( HdCPS, SIZE_HD );
PTR( HdCPS )[ 0 ] = INT_TO_HD( 0 );
}
else
CPP = FALSE;
return HdVoid;
}
return Error( usage, 0L, 0L );
}
#endif
/*--------------------------------------------------------------------------\
| Print functions for T_AGWORD, T_AGLIST, T_AGEXP, T_AGGRP |
\--------------------------------------------------------------------------*/
/****************************************************************************
**
*F PrAgWord( <hdAgWord> ) . . . . . . . . . . . . . . . . prints a T_AGWORD
**
** The function 'PrAgWord' prints an agword in generator-exponent-form,
** if <PRINT_AG> is not set. That is, if the group is generated by a and
** b the word a*a*a*b*b is printed as "a^3*b^2". If <PRINT_AG> is set the
** word is printed as "agword( HD( <aggroup> ); 0, 3; 1, 2; -1 )", where
** <aggroup> is the group record of the agword.
*/
#if ! PRINT_AG
/** Print T_AGWORD in generator-exponent-form. *************************/
void PrAgWord ( hdAgWord )
TypHandle hdAgWord;
{
TypSword * pt, * ptEnd;
TypHandle hdAgGroup;
if ( ISID_AW( hdAgWord ) )
Pr( "IdAgWord", 0L, 0L );
else
{
hdAgGroup = *PTR( hdAgWord );
pt = PTR_AW( hdAgWord );
ptEnd = pt + 2 * ( LEN_AW( hdAgWord ) - 1 );
while ( pt < ptEnd )
{
Pr( "%>%s", (long) NAME_AW( hdAgGroup, *pt++ ), 0L );
if ( *pt != 1 )
Pr( "^%d", (long) *pt, 0L );
Pr( "*%<", 0L, 0L );
pt++;
}
Pr( "%>%s", (long) NAME_AW( hdAgGroup, *pt++ ), 0L );
if ( *pt != 1 )
Pr( "^%d", (long) *pt, 0L );
Pr ("%<", 0L, 0L );
}
}
#else
/** Print T_AGWORD in tuple form. **************************************/
void PrAgWord( hdAgWord )
TypHandle hdAgWord;
{
TypSword * pt, * ptEnd;
/** <hdAgWord> has a group, print the handle of this group ******/
/** followed by all entries. ******/
Pr( "%>agword( %>%d; %<", (long) *PTR( hdAgWord ) / 4L, 0L );
pt = PTR_AW( hdAgWord );
ptEnd = (TypSword*)( (char*) PTR( hdAgWord ) + SIZE( hdAgWord ) );
while ( pt < ptEnd - 1 )
{
Pr( "%>%d, %<", (long) *pt++, 0L );
Pr( "%>%d; %<", (long) *pt++, 0L );
}
if ( pt < ptEnd )
Pr( "%d )%<", (long) *pt, 0L );
else
Pr( ")%<", 0L, 0L );
}
#endif
/****************************************************************************
**
*F PrAgExp( <hdAgExp> ) . . . . . . . . . . . . . . . . . prints a T_AGEXP
**
** Print an object of type T_AGEXP. The exponent vector <hdAgExp> is print
** as tuple "agexp(e_1,...,e_n)". This function is only defined, if the flag
** <PRINT_AG> or <GROUP_REC> is set.
*/
#if PRINT_AG | GROUP_REC
void PrAgExp( hdAgExp )
TypHandle hdAgExp;
{
TypExp * pt, * ptEnd;
pt = (TypExp*) PTR( hdAgExp );
ptEnd = (TypExp*)( (char*) PTR( hdAgExp ) + SIZE( hdAgExp ) );
if ( SIZE( hdAgExp ) == 0 )
/** No generator so just print '( )'. *************************/
Pr( "%>agexp( )%<", 0L, 0L );
else
{
/** Print a tuple '(1, 2, ... )'. ******************************/
Pr( "%>agexp( %<", 0L, 0L );
while ( pt < ptEnd - 1 )
Pr( "%>%d, %<", (long) (*pt++), 0L );
Pr( "%>%d )%<", (long) *pt, 0L );
}
}
#endif
/****************************************************************************
**
*F PrAgList( <hdAgList> ) . . . . . . . . . . . . . . . . prints a T_AGLIST
**
** Print an object of type T_AGLIST. The exponent vector <hdAgList> is print
** as tuple "aglist(g_1, e_1; ... ;g_n, e_n)", where g_i is the number of
** the i.th (non-trivial) generator and e_i its exponent. This function is
** only defined, if <PRINT_AG> or <GROUP_REC> is set.
*/
#if PRINT_AG | GROUP_REC
void PrAgList( hdAgList )
TypHandle hdAgList;
{
TypSword * pt, * ptEnd;
int toggle;
pt = (TypSword*) PTR( hdAgList );
ptEnd = (TypSword*)( (char*) PTR( hdAgList ) + SIZE( hdAgList ) );
if ( SIZE( hdAgList ) == 0 )
/** No generator so just print '( )'. **************************/
Pr( "%>aglist( )%<", 0L, 0L );
else
{
/** Print a tuple '(1, 2; ... )'. ******************************/
toggle = 0;
Pr( "%>aglist( %<", 0L, 0L );
while ( pt < ptEnd - 1 )
{
if ( toggle == 0 )
Pr( "%>%d, %<", (long) (*pt++), 0L );
else
Pr( "%>%d; %<", (long) (*pt++), 0L );
toggle = 1 - toggle;
}
Pr( "%>%d )%<", (long) *pt, 0L );
}
}
#endif
/****************************************************************************
**
*F PrAgen( <hdAgGrp> ) . . . . . . . . . . . . . . . . . . . prints a T_AGEN
**
** 'PrAgen' prints a T_AGEN. This function is only installed if <GROUP_REC>
** or <PRINT_AG> are defined. It is used in order to print the group record
** as it contains T_AGENs in 'WORDS'.
*/
#if PRINT_AG | GROUP_REC
void PrAgen( hdAgen )
TypHandle hdAgen;
{
Pr( "%s", (long)( PTR( hdAgen ) + 1 ), 0L );
}
#endif /* PRINT_AG | GROUP_REC */
/*--------------------------------------------------------------------------\
| Initialize the soluble group module |
\--------------------------------------------------------------------------*/
/****************************************************************************
**
*F InitAg() . . . . . . . . . . . . . . . initializes the collection module
**
** 'InitAg' is called during the initialization to initialize the soluble
** group module.
*/
extern TypHandle HdCallOop1, HdCallOop2;
void InitAg()
{
HdCallOop1 = NewBag( T_FUNCCALL, 2 * SIZE_HD );
HdCallOop2 = NewBag( T_FUNCCALL, 3 * SIZE_HD );
/** Install the evaluator functions. ***********************************/
InstEvFunc( T_AGWORD, EvAg );
TabEq[ T_AGWORD ][ T_AGWORD ] = EqAg;
TabLt[ T_AGWORD ][ T_AGWORD ] = LtAg;
TabProd[ T_AGWORD ][ T_AGWORD ] = ProdAg;
TabQuo [ T_AGWORD ][ T_AGWORD ] = QuoAg;
TabMod [ T_AGWORD ][ T_AGWORD ] = ModAg;
TabPow [ T_AGWORD ][ T_INT ] = PowAgI;
TabPow [ T_AGWORD ][ T_AGWORD ] = PowAgAg;
TabComm[ T_AGWORD ][ T_AGWORD ] = CommAg;
/** Install the print function. If neither <PRINT_AG> nor <GROUP_REC> **/
/** is set, only T_AGWORD can be printed. Other print functions **/
/** for T_AGWORD, T_AGEXP and T_AGLIST are installed. **/
# if ! PRINT_AG
# if ! GROUP_REC /* & ! PRINT_AG */
InstPrFunc( T_AGWORD, PrAgWord );
# else /* GROUP_REC & ! PRINT_AG */
InstPrFunc( T_AGWORD, PrAgWord );
InstPrFunc( T_AGEXP, PrAgExp );
InstPrFunc( T_AGLIST, PrAgList );
InstPrFunc( T_AGEN, PrAgen );
InstIntFunc( "DUMP_LONG", FunDUMPLONG );
# endif /* GROUP_REC */
# else /* PRINT_AG */
InstPrFunc( T_AGWORD, PrAgWord );
InstPrFunc( T_AGEXP, PrAgExp );
InstPrFunc( T_AGLIST, PrAgList );
InstPrFunc( T_AGEN, PrAgen );
InstIntFunc( "DUMP_LONG", FunDUMPLONG );
# endif /* PRINT_AG */
/** Find the various record names so that the corresponding funcs can **/
/** use records which fake to be agwords. **/
HdRnSumAgWord = FindRecname( "SumAgWord" );
HdRnDifferenceAgWord = FindRecname( "DifferenceAgWord" );
HdRnDepth = FindRecname( "Depth" );
HdRnTailDepth = FindRecname( "TailDepth" );
HdRnCentralWeight = FindRecname( "CentralWeight" );
HdRnLeadingExponent = FindRecname( "LeadingExponent" );
HdRnReducedAgWord = FindRecname( "ReducedAgWord" );
HdRnRelativeOrder = FindRecname( "RelativeOrder" );
HdRnExponentAgWord = FindRecname( "ExponentAgWord" );
HdRnExponentsAgWord = FindRecname( "ExponentsAgWord" );
HdRnInformationAgWord = FindRecname( "InformationAgWord" );
HdRnIsCompatibleAgWord = FindRecname( "IsCompatibleAgWord" );
HdRnNormalizeIgs = FindRecname( "NormalizeIgs" );
HdRnIsAgWord = FindRecname( "IsAgWord" );
/** Find some record names for the group record. ***********************/
HdRnAvec = FindRecname( "avec" );
/** Install the various internal functions. All the functions for **/
/** agwords do allow to pass records which fake to be agwords. **/
/** These records must contain an entry 'operations' which has **/
/** an entry of the suitable name. **/
InstIntFunc( "SumAgWord", FunSumAgWord );
InstIntFunc( "DifferenceAgWord", FunDifferenceAgWord );
InstIntFunc( "DepthAgWord", FunDepthAgWord );
InstIntFunc( "TailDepthAgWord", FunTailDepthAgWord );
InstIntFunc( "CentralWeightAgWord", FunCentralWeightAgWord );
InstIntFunc( "LeadingExponentAgWord", FunLeadingExponentAgWord );
InstIntFunc( "ReducedAgWord", FunReducedAgWord );
InstIntFunc( "RelativeOrderAgWord", FunRelativeOrderAgWord );
InstIntFunc( "ExponentAgWord", FunExponentAgWord );
InstIntFunc( "ExponentsAgWord", FunExponentsAgWord );
InstIntFunc( "InformationAgWord", FunInformationAgWord );
InstIntFunc( "IsAgWord", FunIsAgWord );
InstIntFunc( "IsCompatibleAgWord", FunIsCompatibleAgWord );
InstIntFunc( "NormalizeIgs", FunNormalizeIgs );
/** Install the various internal functions. These functions do not **/
/** allow to pass records which fake to be agwords. There should be a **/
/** dispatcher at GAP-level for these functions. **/
InstIntFunc( "AgFpGroup", FunAgFpGroup );
InstIntFunc( "FactorAgWord", FunFactorAgWord );
InstIntFunc( "FactorAgGroup", FunFactorAgGroup );
# if GROUP_REC
InstIntFunc( "AgGroupRecord", FunAgGroupRecord );
# endif /* GROUP_REC */
# if AG_PROFILE
InstIntFunc( "AgProfile", FunAgProfile );
InstIntFunc( "CollectorProfile", FunCollectorProfile );
# endif /* AG_PROFILE */
/** Install internal variables. ****************************************/
# if AG_PROFILE
HdCPL = NewBag( T_LIST, SIZE_HD );
PTR( HdCPL )[ 0 ] = INT_TO_HD( 0 );
HdCPC = NewBag( T_LIST, SIZE_HD );
PTR( HdCPC )[ 0 ] = INT_TO_HD( 0 );
HdCPS = NewBag( T_LIST, SIZE_HD );
PTR( HdCPS )[ 0 ] = INT_TO_HD( 0 );
# endif
/** Install the various internal procedures. ***************************/
InstIntFunc( "SetCollectorAgWord", FunSetCollectorAgWord );
}
/****************************************************************************
**
*E Emacs . . . . . . . . . . . . . . . . . . . . . . . local emacs variables
**
** Local Variables:
** mode: outline
** outline-regexp: "*A\\|*F\\|*V\\|*T\\|*E"
** fill-column: 73
** fill-prefix: "** "
** eval: (local-set-key "\t" 'c-indent-command)
** eval: (local-set-key ";" 'electric-c-semi )
** eval: (local-set-key "{" 'electric-c-brace)
** eval: (local-set-key "}" 'electric-c-brace)
** eval: (hide-body)
** End:
*/
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.