| Download
GAP 4.8.9 installation with standard packages -- copy to your CoCalc project to get it
Project: cocalc-sagemath-dev-slelievre
Views: 415065/****************************************************************************1**2*W costab.c GAP source Frank Celler3*W & Volkmar Felsch4*W & Martin Schönert5*W & Alexander Hulpke6**7**8*Y Copyright (C) 1996, Lehrstuhl D für Mathematik, RWTH Aachen, Germany9*Y (C) 1998 School Math and Comp. Sci., University of St Andrews, Scotland10*Y Copyright (C) 2002 The GAP Group11**12** This file contains the functions of for coset tables.13*/14#include "system.h" /* system dependent part */151617#include "gasman.h" /* garbage collector */18#include "objects.h" /* objects */19#include "scanner.h" /* scanner */2021#include "gap.h" /* error handling, initialisation */2223#include "gvars.h" /* global variables */24#include "calls.h" /* generic call mechanism */25#include "opers.h" /* generic operations */2627#include "integer.h" /* integers */28#include "bool.h" /* booleans */2930#include "records.h" /* generic records */31#include "precord.h" /* plain records */3233#include "lists.h" /* generic lists */34#include "plist.h" /* plain lists */35#include "string.h" /* strings */3637#include "costab.h" /* coset table */3839#include "code.h" /* coder */40#include "thread.h" /* threads */41#include "tls.h" /* thread-local storage */424344/****************************************************************************45**4647*V declaration of static variables48*/49static Obj objRel; /* handle of a relator */50static Obj objNums; /* handle of parallel numbers list */51static Obj objTable; /* handle of the coset table */52static Obj objTable2; /* handle of coset factor table */53static Obj objNext; /* */54static Obj objPrev; /* */55static Obj objFactor; /* */56static Obj objTree; /* handle of subgroup gens tree */5758static Obj objTree1; /* first tree component */59static Obj objTree2; /* second tree component */6061static Obj objExponent; /* handle of subgroup order */62static Obj objWordValue; /* handle of word value */6364static Int treeType; /* tree type */65static Int treeWordLength; /* maximal tree word length */66static Int firstDef; /* */67static Int lastDef; /* */68static Int firstFree; /* */69static Int lastFree; /* */7071static Int minGaps; /* switch for marking mingaps */72static Int nrdel; /* */7374static Int dedfst; /* position of first deduction */75static Int dedlst; /* position of last deduction */76static Int dedgen [40960]; /* deduction list keeping gens */77static Int dedcos [40960]; /* deduction list keeping cosets */78static Int dedSize = 40960; /* size of deduction list buffers */79static Int dedprint; /* print flag for warning */8081static Int wordList [1024]; /* coset rep word buffer */82static Int wordSize = 1023; /* maximal no. of coset rep words */8384/* clean out global Obj-type variables to avoid hogging memory*/85static void CleanOut( void )86{87objRel = (Obj) 0;88objNums = (Obj) 0;89objTable = (Obj) 0;90objTable2 = (Obj) 0;91objNext = (Obj) 0;92objPrev = (Obj) 0;93objFactor = (Obj) 0;94objTree = (Obj) 0;95objTree1 = (Obj) 0;96objTree2 = (Obj) 0;97objExponent = (Obj) 0;98objWordValue = (Obj) 0;99}100101/****************************************************************************102**103104*F FuncApplyRel( <self>, <app>, <rel> ) apply a relator to a coset in a TC105**106** 'FuncApplyRel' implements the internal function 'ApplyRel'.107**108** 'ApplyRel( <app>, <rel> )'109**110** 'ApplyRel' applies the relator <rel> to the application list <app>.111**112** ... more about ApplyRel ...113*/114Obj FuncApplyRel (115Obj self,116Obj app, /* handle of the application list */117Obj rel ) /* handle of the relator */118{119120Int lp; /* left pointer into relator */121Int lc; /* left coset to apply to */122Int rp; /* right pointer into relator */123Int rc; /* right coset to apply to */124Int tc; /* temporary coset */125126/* check the application list */127/*T 1996/12/03 fceller this should be replaced by 'PlistConv' */128if ( ! IS_PLIST(app) ) {129ErrorQuit( "<app> must be a plain list (not a %s)",130(Int)TNAM_OBJ(app), 0L );131return 0;132}133if ( LEN_PLIST(app) != 4 ) {134ErrorQuit( "<app> must be a list of length 4 not %d",135(Int) LEN_PLIST(app), 0L );136return 0;137}138139/* get the four entries */140lp = INT_INTOBJ( ELM_PLIST( app, 1 ) );141lc = INT_INTOBJ( ELM_PLIST( app, 2 ) );142rp = INT_INTOBJ( ELM_PLIST( app, 3 ) );143rc = INT_INTOBJ( ELM_PLIST( app, 4 ) );144145/* get and check the relator (well, only a little bit) */146/*T 1996/12/03 fceller this should be replaced by 'PlistConv' */147if ( ! IS_PLIST(rel) ) {148ErrorQuit( "<rel> must be a plain list (not a %s)",149(Int)TNAM_OBJ(rel), 0L );150return 0;151}152153/* fix right pointer if requested */154if ( rp == -1 )155rp = lp + INT_INTOBJ( ELM_PLIST( rel, 1 ) );156157/* scan as long as possible from the right to the left */158while ( lp < rp159&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,rp),rc))) )160{161rc = tc; rp = rp - 2;162}163164/* scan as long as possible from the left to the right */165while ( lp < rp166&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,lp),lc))) )167{168lc = tc; lp = lp + 2;169}170171/* copy the information back into the application list */172SET_ELM_PLIST( app, 1, INTOBJ_INT( lp ) );173SET_ELM_PLIST( app, 2, INTOBJ_INT( lc ) );174SET_ELM_PLIST( app, 3, INTOBJ_INT( rp ) );175SET_ELM_PLIST( app, 4, INTOBJ_INT( rc ) );176177/* return 'true' if a coincidence or deduction was found */178if ( lp == rp+1179&& INT_INTOBJ(ELM_PLIST(ELM_PLIST(rel,lp),lc)) != rc )180{181return True;182}183else184return False;185}186187188/****************************************************************************189**190*F CompressDeductionList() . . . . removes unused items from deduction list191**192** 'CompressDeductionList' tries to find and delete deduction list entries193** which are not used any more.194**195** 'dedgen', 'dedcos', 'dedfst', 'dedlst', 'dedSize' and 'objTable' are196** assumed to be known as static variables.197*/198static void CompressDeductionList ( void )199{200Obj * ptTable; /* pointer to the coset table */201Int i;202Int j;203204/* check if the situation is as assumed */205if ( dedlst != dedSize ) {206ErrorQuit( "invalid call of CompressDeductionList", 0L, 0L );207return;208}209210/* run through the lists and compress them */211ptTable = &(ELM_PLIST(objTable,1)) - 1;212j = 0;213for ( i = dedfst; i < dedlst; i++ ) {214if ( INT_INTOBJ(ELM_PLIST(ptTable[dedgen[i]],dedcos[i])) > 0215&& j < i )216{217dedgen[j] = dedgen[i];218dedcos[j] = dedcos[i];219j++;220}221}222223/* update the pointers */224dedfst = 0;225dedlst = j;226227/* check if we have at least one free position */228if ( dedlst == dedSize ) {229if ( dedprint == 0 ) {230Pr( "#I WARNING: deductions being discarded\n", 0L, 0L );231dedprint = 1;232}233dedlst--;234}235}236237238/****************************************************************************239**240*F HandleCoinc( <cos1>, <cos2> ) . . . . . . . . handle coincidences in a TC241**242** 'HandleCoinc' is a subroutine of 'FuncMakeConsequences' and handles the243** coincidence cos2 = cos1.244*/245static void HandleCoinc (246Int cos1,247Int cos2 )248{249Obj * ptTable; /* pointer to the coset table */250Obj * ptNext;251Obj * ptPrev;252Int c1;253Int c2;254Int c3;255Int i;256Int firstCoinc;257Int lastCoinc;258Obj * gen;259Obj * inv;260261/* is this test necessary? */262if ( cos1 == cos2 ) return;263264/* get some pointers */265ptTable = &(ELM_PLIST(objTable,1)) - 1;266ptNext = &(ELM_PLIST(objNext,1)) - 1;267ptPrev = &(ELM_PLIST(objPrev,1)) - 1;268269/* take the smaller one as new representative */270if ( cos2 < cos1 ) { c3 = cos1; cos1 = cos2; cos2 = c3; }271272/* if we are removing an important coset update it */273if ( cos2 == lastDef )274lastDef = INT_INTOBJ( ptPrev[lastDef ] );275if ( cos2 == firstDef )276firstDef = INT_INTOBJ( ptPrev[firstDef] );277278/* remove <cos2> from the coset list */279ptNext[INT_INTOBJ(ptPrev[cos2])] = ptNext[cos2];280if ( ptNext[cos2] != INTOBJ_INT( 0 ) )281ptPrev[INT_INTOBJ(ptNext[cos2])] = ptPrev[cos2];282283/* put the first coincidence into the list of coincidences */284firstCoinc = cos2;285lastCoinc = cos2;286ptNext[lastCoinc] = INTOBJ_INT( 0 );287288/* <cos1> is the representative of <cos2> and its own representative */289ptPrev[cos2] = INTOBJ_INT( cos1 );290291/* while there are coincidences to handle */292while ( firstCoinc != 0 ) {293294/* replace <firstCoinc> by its representative in the table */295cos1 = INT_INTOBJ( ptPrev[firstCoinc] ); cos2 = firstCoinc;296for ( i = 1; i <= LEN_PLIST(objTable); i++ ) {297gen = &(ELM_PLIST(ptTable[i],1)) - 1;298/* inv = ADDR_OBJ(ptTable[ ((i-1)^1)+1 ] ); */299inv = &(ELM_PLIST( ptTable[ i + 2*(i % 2) - 1 ], 1 ) ) - 1;300301/* replace <cos2> by <cos1> in the column of <gen>^-1 */302c2 = INT_INTOBJ( gen[cos2] );303if ( c2 > 0 ) {304c1 = INT_INTOBJ( gen[cos1] );305306/* if the other entry is empty copy it */307if ( c1 <= 0 ) {308gen[cos1] = INTOBJ_INT( c2 );309gen[cos2] = INTOBJ_INT( 0 );310inv[c2] = INTOBJ_INT( cos1 );311if ( dedlst == dedSize )312CompressDeductionList( );313dedgen[dedlst] = i;314dedcos[dedlst] = cos1;315dedlst++;316}317318/* otherwise check for a coincidence */319else {320inv[c2] = INTOBJ_INT( 0 );321gen[cos2] = INTOBJ_INT( 0 );322if ( gen[cos1] <= INTOBJ_INT( 0 ) ) {323gen[cos1] = INTOBJ_INT( cos1 );324if ( dedlst == dedSize )325CompressDeductionList( );326dedgen[dedlst] = i;327dedcos[dedlst] = cos1;328dedlst++;329}330331/* find the representative of <c1> */332while ( c1 != 1333&& INT_INTOBJ(ptNext[INT_INTOBJ(ptPrev[c1])]) != c1 )334{335c1 = INT_INTOBJ(ptPrev[c1]);336}337338/* find the representative of <c2> */339while ( c2 != 1340&& INT_INTOBJ(ptNext[INT_INTOBJ(ptPrev[c2])]) != c2 )341{342c2 = INT_INTOBJ(ptPrev[c2]);343}344345/* if the representatives differ we got a coincindence */346if ( c1 != c2 ) {347348/* take the smaller one as new representative */349if ( c2 < c1 ) { c3 = c1; c1 = c2; c2 = c3; }350351/* if we are removing an important coset update it */352if ( c2 == lastDef )353lastDef = INT_INTOBJ(ptPrev[lastDef ]);354if ( c2 == firstDef )355firstDef = INT_INTOBJ(ptPrev[firstDef]);356357/* remove <c2> from the coset list */358ptNext[INT_INTOBJ(ptPrev[c2])] = ptNext[c2];359if ( ptNext[c2] != INTOBJ_INT( 0 ) )360ptPrev[INT_INTOBJ(ptNext[c2])] = ptPrev[c2];361362/* append <c2> to the coincidence list */363ptNext[lastCoinc] = INTOBJ_INT( c2 );364lastCoinc = c2;365ptNext[lastCoinc] = INTOBJ_INT( 0 );366367/* <c1> is the rep of <c2> and its own rep. */368ptPrev[c2] = INTOBJ_INT( c1 );369}370}371}372373/* save minimal gap flags */374else if ( minGaps != 0 && c2 == -1 ) {375if ( gen[cos1] <= INTOBJ_INT( 0 ) ) {376gen[cos1] = INTOBJ_INT( -1 );377}378gen[cos2] = INTOBJ_INT( 0 );379}380}381382/* move the replaced coset to the free list */383if ( firstFree == 0 ) {384firstFree = firstCoinc;385lastFree = firstCoinc;386}387else {388ptNext[lastFree] = INTOBJ_INT( firstCoinc );389lastFree = firstCoinc;390}391firstCoinc = INT_INTOBJ( ptNext[firstCoinc] );392ptNext[lastFree] = INTOBJ_INT( 0 );393394nrdel++;395}396}397398399/****************************************************************************400**401*F FuncMakeConsequences( <self>, <list> ) find consqs of a coset definition402*/403Obj FuncMakeConsequences (404Obj self,405Obj list )406{407Obj hdSubs; /* */408Obj objRels; /* */409Obj * ptRel; /* pointer to the relator bag */410Obj * ptNums; /* pointer to this list */411Int lp; /* left pointer into relator */412Int lc; /* left coset to apply to */413Int rp; /* right pointer into relator */414Int rc; /* right coset to apply to */415Int tc; /* temporary coset */416Int i; /* loop variable */417Obj hdTmp; /* temporary variable */418419/*T 1996/12/03 fceller this should be replaced by 'PlistConv' */420if ( ! IS_PLIST(list) ) {421ErrorQuit( "<list> must be a plain list (not a %s)",422(Int)TNAM_OBJ(list), 0L );423return 0;424}425426objTable = ELM_PLIST( list, 1 );427objNext = ELM_PLIST( list, 2 );428objPrev = ELM_PLIST( list, 3 );429430firstFree = INT_INTOBJ( ELM_PLIST( list, 6 ) );431lastFree = INT_INTOBJ( ELM_PLIST( list, 7 ) );432firstDef = INT_INTOBJ( ELM_PLIST( list, 8 ) );433lastDef = INT_INTOBJ( ELM_PLIST( list, 9 ) );434minGaps = INT_INTOBJ( ELM_PLIST( list, 12 ) );435436nrdel = 0;437438/* initialize the deduction queue */439dedprint = 0;440dedfst = 0;441dedlst = 1;442dedgen[ 0 ] = INT_INTOBJ( ELM_PLIST( list, 10 ) );443dedcos[ 0 ] = INT_INTOBJ( ELM_PLIST( list, 11 ) );444445/* while the deduction queue is not empty */446while ( dedfst < dedlst ) {447448/* skip the deduction, if it got irrelevant by a coincidence */449hdTmp = ELM_PLIST( objTable, dedgen[dedfst] );450hdTmp = ELM_PLIST( hdTmp, dedcos[dedfst] );451if ( INT_INTOBJ(hdTmp) <= 0 ) {452dedfst++;453continue;454}455456/* while there are still subgroup generators apply them */457hdSubs = ELM_PLIST( list, 5 );458for ( i = LEN_LIST( hdSubs ); 1 <= i; i-- ) {459if ( ELM_PLIST( hdSubs, i ) != 0 ) {460objNums = ELM_PLIST( ELM_PLIST( hdSubs, i ), 1 );461ptNums = &(ELM_PLIST(objNums,1)) - 1;462objRel = ELM_PLIST( ELM_PLIST( hdSubs, i ), 2 );463ptRel = &(ELM_PLIST(objRel,1)) - 1;464465lp = 2;466lc = 1;467rp = LEN_LIST( objRel ) - 1;468rc = 1;469470/* scan as long as possible from the right to the left */471while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {472rc = tc; rp = rp - 2;473}474475/* scan as long as possible from the left to the right */476while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {477lc = tc; lp = lp + 2;478}479480/* if a coincidence or deduction has been found, handle it */481if ( lp == rp + 1 ) {482if ( INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc ) {483if ( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ) > 0 ) {484HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ), rc );485}486else if ( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ) > 0 ) {487HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ), lc );488}489else {490SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );491SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );492if ( dedlst == dedSize )493CompressDeductionList();494dedgen[ dedlst ] = INT_INTOBJ( ptNums[lp] );495dedcos[ dedlst ] = lc;496dedlst++;497}498}499500/* remove the completed subgroup generator */501SET_ELM_PLIST( hdSubs, i, 0 );502if ( i == LEN_PLIST(hdSubs) ) {503while ( 0 < i && ELM_PLIST(hdSubs,i) == 0 )504--i;505SET_LEN_PLIST( hdSubs, i );506i++;507}508}509510/* if a minimal gap has been found, set a flag */511else if ( minGaps != 0 && lp == rp - 1 ) {512SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( -1 ) );513SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( -1 ) );514}515}516}517518/* apply all relators that start with this generator */519objRels = ELM_PLIST( ELM_PLIST( list, 4 ), dedgen[dedfst] );520for ( i = 1; i <= LEN_LIST( objRels ); i++ ) {521objNums = ELM_PLIST( ELM_PLIST(objRels,i), 1 );522ptNums = &(ELM_PLIST(objNums,1)) - 1;523objRel = ELM_PLIST( ELM_PLIST(objRels,i), 2 );524ptRel = &(ELM_PLIST(objRel,1)) - 1;525526lp = INT_INTOBJ( ELM_PLIST( ELM_PLIST(objRels,i), 3 ) );527lc = dedcos[ dedfst ];528rp = lp + INT_INTOBJ( ptRel[1] );529rc = lc;530531/* scan as long as possible from the right to the left */532while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {533rc = tc; rp = rp - 2;534}535536/* scan as long as possible from the left to the right */537while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {538lc = tc; lp = lp + 2;539}540541/* if a coincidence or deduction has been found, handle it */542if ( lp == rp+1 && INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc ) {543if ( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ) > 0 ) {544HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[lp],lc) ), rc );545}546else if ( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ) > 0 ) {547HandleCoinc( INT_INTOBJ( ELM_PLIST(ptRel[rp],rc) ), lc );548}549else {550SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );551SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );552if ( dedlst == dedSize )553CompressDeductionList();554dedgen[ dedlst ] = INT_INTOBJ( ptNums[lp] );555dedcos[ dedlst ] = lc;556dedlst++;557}558}559560/* if a minimal gap has been found, set a flag */561else if ( minGaps != 0 && lp == rp - 1 ) {562SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( -1 ) );563SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( -1 ) );564}565}566567dedfst++;568}569570SET_ELM_PLIST( list, 6, INTOBJ_INT( firstFree ) );571SET_ELM_PLIST( list, 7, INTOBJ_INT( lastFree ) );572SET_ELM_PLIST( list, 8, INTOBJ_INT( firstDef ) );573SET_ELM_PLIST( list, 9, INTOBJ_INT( lastDef ) );574575/* clean out */576CleanOut();577578return INTOBJ_INT( nrdel );579}580581582/****************************************************************************583**584*F FuncMakeConsequencesPres( <self>, <list> ) . . . . . . find consequences585**586** This is a special version of `FuncMakeConsequences' for the subgroup587** presentation routines.588*/589Obj FuncMakeConsequencesPres (590Obj self,591Obj list )592{593Obj objDefs1; /* handle of defs list part 1 */594Obj objDefs2; /* handle of defs list part 2 */595Obj objRels; /* */596Obj * ptRel; /* pointer to the relator bag */597Obj * ptNums; /* pointer to this list */598Int ndefs; /* number of defs done so far */599Int undefined; /* maximal of undefined entreis */600Int apply; /* num of next def to be applied */601Int ndefsMax; /* maximal number of definitons */602Int coset; /* coset involved in current def */603Int gen; /* gen involved in current def */604Int lp; /* left pointer into relator */605Int lc; /* left coset to apply to */606Int rp; /* right pointer into relator */607Int rc; /* right coset to apply to */608Int tc; /* temporary coset */609Int i; /* loop variable */610611/*T 1996/12/03 fceller this should be replaced by 'PlistConv' */612if ( ! IS_PLIST(list) ) {613ErrorQuit( "<list> must be a plain list (not a %s)",614(Int)TNAM_OBJ(list), 0L );615return 0;616}617618objTable = ELM_PLIST( list, 1 );619objDefs1 = ELM_PLIST( list, 2 );620objDefs2 = ELM_PLIST( list, 3 );621622undefined = INT_INTOBJ( ELM_PLIST( list, 4 ) );623ndefs = INT_INTOBJ( ELM_PLIST( list, 5 ) );624625/* check the definitions lists */626if ( ! ( IS_PLIST(objDefs1) && IS_PLIST(objDefs2) &&627LEN_PLIST(objDefs1) == LEN_PLIST(objDefs2) ) ) {628ErrorQuit( "inconsistent definitions lists", 0L, 0L );629return 0;630}631ndefsMax = LEN_PLIST(objDefs1);632apply = 1;633634/* while the deduction queue is not worked off */635while ( apply <= ndefs ) {636637/* apply all relators that start with this generator */638coset = INT_INTOBJ( ELM_PLIST( objDefs1, apply ) );639gen = INT_INTOBJ( ELM_PLIST( objDefs2, apply ) );640objRels = ELM_PLIST( ELM_PLIST( list, 6 ), gen );641for ( i = 1; i <= LEN_LIST( objRels ); i++ ) {642objNums = ELM_PLIST( ELM_PLIST(objRels,i), 1 );643ptNums = &(ELM_PLIST(objNums,1)) - 1;644objRel = ELM_PLIST( ELM_PLIST(objRels,i), 2 );645ptRel = &(ELM_PLIST(objRel,1)) - 1;646647lp = INT_INTOBJ( ELM_PLIST( ELM_PLIST(objRels,i), 3 ) );648lc = coset;649rp = lp + INT_INTOBJ( ptRel[1] );650rc = lc;651652/* scan as long as possible from the right to the left */653while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) ) {654rc = tc; rp = rp - 2;655}656657/* scan as long as possible from the left to the right */658while ( lp<rp && 0 < (tc=INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) ) {659lc = tc; lp = lp + 2;660}661662/* if a deduction has been found, handle it */663if ( lp == rp+1 && INT_INTOBJ(ELM_PLIST(ptRel[rp],rc)) <= 0 ) {664SET_ELM_PLIST( ptRel[lp], lc, INTOBJ_INT( rc ) );665undefined--;666if ( INT_INTOBJ(ELM_PLIST(ptRel[rp],rc)) <= 0 ) {667SET_ELM_PLIST( ptRel[rp], rc, INTOBJ_INT( lc ) );668undefined--;669}670ndefs++;671if ( ndefs > ndefsMax ) {672ErrorQuit( "inconsistent definitions lists", 0L, 0L );673return 0;674}675SET_ELM_PLIST( objDefs1, ndefs, INTOBJ_INT( lc ) );676SET_ELM_PLIST( objDefs2, ndefs, ptNums[lp] );677if ( undefined == 0 ) {678return INTOBJ_INT( 0 );679}680}681}682683apply++;684}685686/* clean out */687CleanOut();688689return INTOBJ_INT( undefined );690}691692693/****************************************************************************694**695*F FuncStandardizeTableC(<self>,<table>,<stan>) . . . . . . standardize CT696**697** This is the kernel routine for standardizing a coset table. It is called698** by the GAP routine 'StandardizeTable'. The user should not call the699** kernel routine but only the GAP routine.700**701** If <stan> = 1 the table is standardized using the (old) semilenlex702** standard.703** If not <stan> = 1 the table is standardized using the (new) lenlex704** standard (this is the default).705*/706Obj FuncStandardizeTableC (707Obj self,708Obj list,709Obj stan )710{711Obj * ptTable; /* pointer to table */712UInt nrgen; /* number of rows of the table / 2 */713Obj * g; /* one generator list from table */714Obj * h; /* generator list */715Obj * i; /* and inverse */716UInt acos; /* actual coset */717UInt lcos; /* last seen coset */718UInt mcos; /* */719UInt c1, c2; /* coset temporaries */720Obj tmp; /* temporary for swap */721UInt j, k, nloop; /* loop variables */722723/* get the arguments */724objTable = list;725if ( ! IS_PLIST(objTable) ) {726ErrorQuit( "<table> must be a plain list (not a %s)",727(Int)TNAM_OBJ(objTable), 0L );728return 0;729}730ptTable = &(ELM_PLIST(objTable,1)) - 1;731nrgen = LEN_PLIST(objTable) / 2;732for ( j = 1; j <= nrgen*2; j++ ) {733if ( ! IS_PLIST(ptTable[j]) ) {734ErrorQuit(735"<table>[%d] must be a plain list (not a %s)",736(Int)j,737(Int)TNAM_OBJ(ptTable[j]) );738return 0;739}740}741if ( IS_INTOBJ(stan) && INT_INTOBJ(stan) == 1 ) {742/* use semilenlex standard */743nloop = nrgen;744}745else {746/* use lenlex standard */747nloop = nrgen*2;748}749750/* run over all cosets */751acos = 1;752lcos = 1;753while ( acos <= lcos ) {754755/* scan through all columns of acos */756for ( j = 1; j <= nloop; j++ ) {757k = ( nloop == nrgen ) ? 2*j - 1 : j;758g = &(ELM_PLIST(ptTable[k],1)) - 1;759760/* if we haven't seen this coset yet */761if ( lcos+1 < INT_INTOBJ( g[acos] ) ) {762763/* swap rows lcos and g[acos] */764lcos = lcos + 1;765mcos = INT_INTOBJ( g[acos] );766for ( k = 1; k <= nrgen; k++ ) {767h = &(ELM_PLIST(ptTable[2*k-1],1)) - 1;768i = &(ELM_PLIST(ptTable[2*k],1)) - 1;769c1 = INT_INTOBJ( h[lcos] );770c2 = INT_INTOBJ( h[mcos] );771if ( c1 != 0 ) i[c1] = INTOBJ_INT( mcos );772if ( c2 != 0 ) i[c2] = INTOBJ_INT( lcos );773tmp = h[lcos];774h[lcos] = h[mcos];775h[mcos] = tmp;776if ( i != h ) {777c1 = INT_INTOBJ( i[lcos] );778c2 = INT_INTOBJ( i[mcos] );779if ( c1 != 0 ) h[c1] = INTOBJ_INT( mcos );780if ( c2 != 0 ) h[c2] = INTOBJ_INT( lcos );781tmp = i[lcos];782i[lcos] = i[mcos];783i[mcos] = tmp;784}785}786787}788789/* if this is already the next only bump lcos */790else if ( lcos < INT_INTOBJ( g[acos] ) ) {791lcos = lcos + 1;792}793794}795796acos = acos + 1;797}798799/* shrink the table */800for ( j = 1; j <= nrgen; j++ ) {801SET_LEN_PLIST( ptTable[2*j-1], lcos );802SET_LEN_PLIST( ptTable[2*j ], lcos );803}804805/* clean out */806CleanOut();807808/* return void */809return 0;810}811812813/****************************************************************************814**815*F InitializeCosetFactorWord() . . . . . . . initialize a coset factor word816**817** 'InitializeCosetFactorWord' initializes a word in which a new coset818** factor is to be built up.819**820** 'wordList', 'treeType', 'objTree2', and 'treeWordLength' are assumed to821** be known as static variables.822*/823static void InitializeCosetFactorWord ( void )824{825Obj * ptWord; /* pointer to the word */826Int i; /* integer variable */827828/* handle the one generator MTC case */829if ( treeType == 1 ) {830objWordValue = INTOBJ_INT(0);831}832833/* handle the abelianized case */834else if ( treeType == 0 ) {835ptWord = &(ELM_PLIST(objTree2,1)) - 1;836for ( i = 1; i <= treeWordLength; i++ ) {837ptWord[i] = INTOBJ_INT(0);838}839}840841/* handle the general case */842else {843wordList[0] = 0;844}845}846847848/****************************************************************************849**850*F TreeEntryC() . . . . . . . . . . . . returns a tree entry for a rep word851**852** 'TreeEntryC' determines a tree entry which represents the word given in853** 'wordList', if it finds any, or it defines a new proper tree entry, and854** then returns it.855**856** Warning: It is assumed, but not checked, that the given word is freely857** reduced and that it does not contain zeros, and that the tree type is858** either 0 or 2.859**860** 'wordList' is assumed to be known as static variable.861**862*/863static Int TreeEntryC ( void )864{865Obj * ptTree1; /* ptr to first tree component */866Obj * ptTree2; /* ptr to second tree component */867Obj * ptWord; /* ptr to given word */868Obj * ptFac; /* ptr to old word */869Obj * ptNew; /* ptr to new word */870Obj objNew; /* handle of new word */871Int treesize; /* tree size */872Int numgens; /* tree length */873Int leng; /* word length */874Int sign; /* sign flag */875Int i, k; /* integer variables */876Int gen; /* generator value */877Int u, u1, u2; /* generator values */878Int v, v1, v2; /* generator values */879Int t1, t2; /* generator values */880Int uabs, vabs; /* generator values */881882/* Get the tree components */883ptTree1 = &(ELM_PLIST(objTree1,1)) - 1;884ptTree2 = &(ELM_PLIST(objTree2,1)) - 1;885treesize = LEN_PLIST(objTree1);886numgens = INT_INTOBJ( ELM_PLIST( objTree, 3 ) );887888/* handle the abelianized case */889if ( treeType == 0 )890{891ptWord = &(ELM_PLIST(objTree2,1)) - 1;892for ( leng = treeWordLength; leng >= 1; leng-- ) {893if ( ptWord[leng] != INTOBJ_INT(0) ) {894break;895}896}897if ( leng == 0 ) {898return 0;899}900for ( k = 1; k <= leng; k++ ) {901if ( ptWord[k] != INTOBJ_INT(0) ) {902break;903}904}905sign = 1;906if ( INT_INTOBJ( ptWord[k] ) < 0 ) {907908/* invert the word */909sign = - 1;910for ( i = k; i <= leng; i++ ) {911ptWord[i] = INTOBJ_INT( - INT_INTOBJ( ptWord[i] ) );912}913}914for ( k = 1; k <= numgens; k++ ) {915ptFac = &(ELM_PLIST(ptTree1[k],1)) - 1;916if ( LEN_PLIST(ptTree1[k]) == leng ) {917for ( i = 1; i <= leng; i++ ) {918if ( ptFac[i] != ptWord[i] ) {919break;920}921}922if ( i > leng ) {923return sign * k;924}925}926}927928/* extend the tree */929numgens++;930if ( treesize < numgens ) {931treesize = 2 * treesize;932GROW_PLIST( objTree1, treesize );933CHANGED_BAG(objTree);934}935objNew = NEW_PLIST( T_PLIST, leng );936SET_LEN_PLIST( objNew, leng );937938SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );939940SET_LEN_PLIST( objTree1, treesize );941SET_ELM_PLIST( objTree1, numgens, objNew );942CHANGED_BAG(objTree1);943944/* copy the word to the new bag */945ptWord = &(ELM_PLIST(objTree2,1)) - 1;946ptNew = &(ELM_PLIST(objNew,1)) - 1;947while ( leng > 0 ) {948ptNew[leng] = ptWord[leng];949leng--;950}951952return sign * numgens;953}954955/* handle the general case */956957/* Get the length of the word */958leng = wordList[0];959960gen = ( leng == 0 ) ? 0 : wordList[1];961u2 = 0; /* just to shut up gcc */962for ( i = 2; i <= leng; i++ ) {963u = gen;964v = wordList[i];965while ( i ) {966967/* First handle the trivial cases */968if ( u == 0 || v == 0 || ( u + v ) == 0 ) {969gen = u + v;970break;971}972973/* Cancel out factors, if possible */974u1 = INT_INTOBJ( ptTree1[ (u > 0) ? u : -u ] );975if ( u1 != 0 ) {976if ( u > 0 ) {977u2 = INT_INTOBJ( ptTree2[u] );978}979else {980u2 = - u1;981u1 = - INT_INTOBJ( ptTree2[-u] );982}983if ( u2 == -v ) {984gen = u1;985break;986}987}988v1 = INT_INTOBJ( ptTree1[ (v > 0) ? v : -v ] );989if ( v1 != 0 ) {990if ( v > 0 ) {991v2 = INT_INTOBJ( ptTree2[v] );992}993else {994v2 = - v1;995v1 = - INT_INTOBJ( ptTree2[-v] );996}997if ( v1 == -u ) {998gen = v2;999break;1000}1001if ( u1 != 0 && v1 == - u2 ) {1002u = u1;1003v = v2;1004continue;1005}1006}10071008/* Check if there is already a tree entry [u,v] or [-v,-u] */1009if ( u < -v ) {1010t1 = u;1011t2 = v;1012}1013else {1014t1 = -v;1015t2 = -u;1016}1017uabs = ( u > 0 ) ? u : -u;1018vabs = ( v > 0 ) ? v : -v;1019k = ( uabs > vabs ) ? uabs : vabs;1020for ( k++; k <= numgens; k++ ) {1021if ( INT_INTOBJ(ptTree1[k]) == t1 &&1022INT_INTOBJ(ptTree2[k]) == t2 )1023{1024break;1025}1026}10271028/* Extend the tree, if necessary */1029if ( k > numgens ) {1030numgens++;1031if ( treesize < numgens ) {1032treesize = 2 * treesize;1033GROW_PLIST( objTree1, treesize );1034GROW_PLIST( objTree2, treesize );1035ptTree1 = &(ELM_PLIST(objTree1,1)) - 1;1036ptTree2 = &(ELM_PLIST(objTree2,1)) - 1;1037SET_LEN_PLIST( objTree1, treesize );1038SET_LEN_PLIST( objTree2, treesize );1039CHANGED_BAG(objTree);1040}1041ptTree1[numgens] = INTOBJ_INT( t1 );1042ptTree2[numgens] = INTOBJ_INT( t2 );1043SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );1044}1045gen = ( u > - v ) ? -k : k;1046break;1047}1048}10491050return gen;1051}105210531054/****************************************************************************1055**1056*F AddCosetFactor2( <factor> ) . add a factor to a coset representative word1057**1058** 'AddCosetFactor2' adds a factor to a coset representative word and1059** extends the tree appropriately, if necessary.1060**1061** 'treeType', 'wordList', and 'wordSize' are assumed to be known as static1062** variables, and 'treeType' is assumed to be either 0 or 2,1063**1064** Warning: 'factor' is not checked for being zero.1065*/1066static void AddCosetFactor2 (1067Int factor )1068{1069Obj * ptFac; /* pointer to the factor */1070Obj * ptWord; /* pointer to the word */1071Int leng; /* length of the factor */1072Obj sum; /* intermediate result */1073Int i; /* integer variable */1074Obj tmp;10751076/* handle the abelianized case */1077if ( treeType == 0 ) {1078ptWord = &(ELM_PLIST(objTree2,1)) - 1;1079if ( factor > 0 ) {1080tmp = ELM_PLIST( objTree1, factor );1081ptFac = &(ELM_PLIST(tmp,1)) - 1;1082leng = LEN_PLIST(tmp);1083for ( i = 1; i <= leng; i++ ) {1084if ( ! SUM_INTOBJS( sum, ptWord[i], ptFac[i] ) ) {1085ErrorQuit(1086"exponent too large, Modified Todd-Coxeter aborted",10870L, 0L );1088return;1089}1090ptWord[i] = sum;1091}1092}1093else1094{1095tmp = ELM_PLIST( objTree1, -factor );1096ptFac = &(ELM_PLIST(tmp,1)) - 1;1097leng = LEN_PLIST(tmp);1098for ( i = 1; i <= leng; i++ ) {1099if ( ! DIFF_INTOBJS( sum, ptWord[i], ptFac[i] ) ) {1100ErrorQuit(1101"exponent too large, Modified Todd-Coxeter aborted",11020L, 0L );1103return;1104}1105ptWord[i] = sum;1106}1107}1108}11091110/* handle the general case */1111else if ( wordList[0] == 0 ) {1112wordList[++wordList[0]] = factor;1113}1114else if ( wordList[wordList[0]] == -factor ) {1115--wordList[0];1116}1117else if ( wordList[0] < wordSize ) {1118wordList[++wordList[0]] = factor;1119}1120else {1121wordList[0] = ( wordList[1] = TreeEntryC( ) == 0 ) ? 0 : 1;1122AddCosetFactor2(factor);1123}1124}112511261127/****************************************************************************1128**1129*F FuncApplyRel2( <self>, <app>, <rel>, <nums> ) . . . . . . apply a relator1130**1131** 'FunApplyRel2' implements the internal function 'ApplyRel2'.1132**1133** 'ApplyRel2( <app>, <rel>, <nums> )'1134**1135** 'ApplyRel2' applies the relator <rel> to a coset representative and1136** returns the corresponding factors in "word"1137**1138** ...more about ApplyRel2...1139*/1140Obj FuncApplyRel2 (1141Obj self,1142Obj app,1143Obj rel,1144Obj nums )1145{1146Obj * ptApp; /* pointer to that list */1147Obj word; /* handle of resulting word */1148Obj * ptWord; /* pointer to this word */1149Obj * ptTree; /* pointer to the tree */1150Obj * ptTree2; /* ptr to second tree component */1151Obj * ptRel; /* pointer to the relator bag */1152Obj * ptNums; /* pointer to this list */1153Obj * ptTabl2; /* pointer to coset factor table */1154Obj objRep; /* handle of temporary factor */1155Int lp; /* left pointer into relator */1156Int lc; /* left coset to apply to */1157Int rp; /* right pointer into relator */1158Int rc; /* right coset to apply to */1159Int rep; /* temporary factor */1160Int tc; /* temporary coset */1161Int bound; /* maximal number of steps */1162Int last; /* proper word length */1163Int size; /* size of the word bag */1164Int i; /* loop variables */1165Int tmp;11661167/* get and check the application list */1168if ( ! IS_PLIST(app) ) {1169ErrorQuit( "<app> must be a plain list (not a %s)",1170(Int)TNAM_OBJ(app), 0L );1171return 0;1172}1173if ( LEN_PLIST(app) != 9 ) {1174ErrorQuit( "<app> must be a list of length 9 not %d",1175(Int) LEN_PLIST(app), 0L );1176return 0;1177}1178ptApp = &(ELM_PLIST(app,1)) - 1;11791180/* get the components of the proper application list */1181lp = INT_INTOBJ( ptApp[1] );1182lc = INT_INTOBJ( ptApp[2] );1183rp = INT_INTOBJ( ptApp[3] );1184rc = INT_INTOBJ( ptApp[4] );11851186/* get and check the relator (well, only a little bit) */1187objRel = rel;1188if ( ! IS_PLIST(rel) ) {1189ErrorQuit( "<rel> must be a plain list (not a %s)",1190(Int)TNAM_OBJ(rel), 0L );1191return 0;1192}11931194/* fix right pointer if requested */1195if ( rp == -1 )1196rp = lp + INT_INTOBJ( ELM_PLIST(objRel,1) );11971198/* get and check the numbers list parallel to the relator */1199objNums = nums;1200if ( ! IS_PLIST(objNums) ) {1201ErrorQuit( "<nums> must be a plain list (not a %s)",1202(Int)TNAM_OBJ(objNums), 0L );1203return 0;1204}12051206/* get and check the corresponding factors list */1207objTable2 = ptApp[6];1208if ( ! IS_PLIST(objTable2) ) {1209ErrorQuit( "<nums> must be a plain list (not a %s)",1210(Int)TNAM_OBJ(objTable2), 0L );1211return 0;1212}12131214/* get the tree type */1215treeType = INT_INTOBJ( ptApp[5] );12161217/* handle the one generator MTC case */1218if ( treeType == 1 ) {12191220/* initialize the resulting exponent by zero */1221objExponent = INTOBJ_INT( 0 );12221223/* scan as long as possible from the left to the right */1224while ( lp < rp + 2 &&12250 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )1226{1227tmp = INT_INTOBJ( ELM_PLIST(objNums,lp) );1228objRep = ELM_PLIST( objTable2, tmp );1229objRep = ELM_PLIST( objRep, lc );1230objExponent = DiffInt( objExponent, objRep );1231lc = tc;1232lp = lp + 2;1233}12341235/* scan as long as possible from the right to the left */1236while ( lp < rp + 2 &&12370 < (tc = INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )1238{1239tmp = INT_INTOBJ( ELM_PLIST(objNums,rp) );1240objRep = ELM_PLIST( objTable2, tmp );1241objRep = ELM_PLIST( objRep, rc );1242objExponent = SumInt( objExponent, objRep );1243rc = tc;1244rp = rp - 2;1245}12461247/* The functions DiffInt or SumInt may have caused a garbage */1248/* collections. So restore the pointer. */12491250/* save the resulting exponent */1251SET_ELM_PLIST( app, 9, objExponent );1252}12531254else {12551256/* get and check the corresponding word */1257word = ptApp[7];1258if ( ! IS_PLIST(word) ) {1259ErrorQuit( "<word> must be a plain list (not a %s)",1260(Int)TNAM_OBJ(word), 0L );1261return 0;1262}12631264/* handle the abelianized case */1265if ( treeType == 0 ) {1266objTree = ptApp[8];1267objTree1 = ELM_PLIST( objTree, 1 );1268objTree2 = ELM_PLIST( objTree, 2 );1269ptTree = &(ELM_PLIST(objTree,1)) - 1;1270treeWordLength = INT_INTOBJ( ptTree[4] );1271if ( LEN_PLIST(objTree2) != treeWordLength ) {1272ErrorQuit( "ApplyRel2: illegal word length", 0L, 0L );1273return 0;1274}12751276/* initialize the coset representative word */1277InitializeCosetFactorWord();12781279/* scan as long as possible from the left to the right */1280while ( lp < rp + 2 &&12810 < (tc=INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )1282{1283tmp = INT_INTOBJ( ELM_PLIST(objNums,lp) );1284objRep = ELM_PLIST(objTable2,tmp);1285objRep = ELM_PLIST(objRep,lc);1286rep = INT_INTOBJ(objRep);1287if ( rep != 0 ) {1288AddCosetFactor2(-rep);1289}1290lc = tc;1291lp = lp + 2;1292}12931294/* scan as long as possible from the right to the left */1295while ( lp < rp + 2 &&12960 < (tc=INT_INTOBJ(ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )1297{1298tmp = INT_INTOBJ( ELM_PLIST(objNums,rp) );1299objRep = ELM_PLIST(objTable2,tmp);1300objRep = ELM_PLIST(objRep,rc);1301rep = INT_INTOBJ(objRep);1302if ( rep != 0 ) {1303AddCosetFactor2(rep);1304}1305rc = tc;1306rp = rp - 2;1307}13081309/* initialize some local variables */1310ptWord = &(ELM_PLIST(word,1)) - 1;1311ptTree2 = &(ELM_PLIST(objTree2,1)) - 1;13121313/* copy the result to its destination, if necessary */1314if ( ptWord != ptTree2 ) {1315if ( LEN_PLIST(word) != treeWordLength ) {1316ErrorQuit( "illegal word length", 0L, 0L );1317return 0;1318}1319for ( i = 1; i <= treeWordLength; i++ ) {1320ptWord[i] = ptTree2[i];1321}1322SET_LEN_PLIST( word, LEN_PLIST(objTree2) );1323}1324}13251326/* handle the general case */1327else {13281329/* extend the word size, if necessary */1330bound = ( rp - lp + 3 ) / 2;1331size = SIZE_OBJ(word)/sizeof(Obj) - 1;1332if ( size < bound ) {1333size = ( bound > 2 * size ) ? bound : 2 * size;1334GROW_PLIST( word, size );1335CHANGED_BAG(app);1336}13371338/* initialize some local variables */1339ptRel = &(ELM_PLIST(objRel,1)) - 1;1340ptNums = &(ELM_PLIST(objNums,1)) - 1;1341ptTabl2 = &(ELM_PLIST(objTable2,1)) - 1;1342ptWord = &(ELM_PLIST(word,1)) - 1;1343last = 0;13441345/* scan as long as possible from the left to the right */1346while ( lp < rp + 21347&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) )1348{1349objRep = ELM_PLIST( ptTabl2[INT_INTOBJ(ptNums[lp])], lc );1350rep = INT_INTOBJ(objRep);1351if ( rep != 0 ) {1352if ( last > 0 && INT_INTOBJ(ptWord[last]) == rep ) {1353last--;1354}1355else {1356ptWord[++last] = INTOBJ_INT(-rep);1357}1358}1359lc = tc;1360lp = lp + 2;1361}13621363/* revert the ordering of the word constructed so far */1364if ( last > 0 ) {1365last++;1366for ( i = last / 2; i > 0; i-- ) {1367objRep = ptWord[i];1368ptWord[i] = ptWord[last-i];1369ptWord[last-i] = objRep;1370}1371last--;1372}13731374/* scan as long as possible from the right to the left */1375while ( lp < rp + 21376&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) )1377{1378objRep = ELM_PLIST( ptTabl2[INT_INTOBJ(ptNums[rp])], rc );1379rep = INT_INTOBJ(objRep);1380if ( rep != 0 ) {1381if ( last > 0 && INT_INTOBJ(ptWord[last]) == -rep ) {1382last--;1383}1384else {1385ptWord[++last] = INTOBJ_INT(rep);1386}1387}1388rc = tc;1389rp = rp - 2;1390}13911392/* save the word length */1393SET_LEN_PLIST( word, last );1394}1395}13961397/* copy the information back into the application list */1398SET_ELM_PLIST( app, 1, INTOBJ_INT( lp ) );1399SET_ELM_PLIST( app, 2, INTOBJ_INT( lc ) );1400SET_ELM_PLIST( app, 3, INTOBJ_INT( rp ) );1401SET_ELM_PLIST( app, 4, INTOBJ_INT( rc ) );14021403/* return nothing */1404return 0;1405}140614071408/****************************************************************************1409**1410*F FuncCopyRel( <self>, <rel> ) . . . . . . . . . . . . copy of a relator1411**1412** 'FuncCopyRel' returns a copy of the given RRS relator such that the bag1413** of the copy does not exceed the minimal required size.1414*/1415Obj FuncCopyRel (1416Obj self,1417Obj rel ) /* the given relator */1418{1419Obj * ptRel; /* pointer to the given relator */1420Obj copy; /* the copy */1421Obj * ptCopy; /* pointer to the copy */1422Int leng; /* length of the given word */14231424/* Get and check argument */1425if ( ! IS_PLIST(rel) ) {1426ErrorQuit( "<rel> must be a plain list (not a %s)",1427(Int)TNAM_OBJ(rel), 0L );1428return 0;1429}1430leng = LEN_PLIST(rel);14311432/* Allocate a bag for the copy */1433copy = NEW_PLIST( T_PLIST, leng );1434SET_LEN_PLIST( copy, leng );1435ptRel = &(ELM_PLIST(rel,1));1436ptCopy = &(ELM_PLIST(copy,1));14371438/* Copy the relator to the new bag */1439while ( leng > 0 ) {1440*ptCopy++ = *ptRel++;1441leng--;1442}14431444/* Return the copy */1445return copy;1446}144714481449/****************************************************************************1450**1451*F FuncMakeCanonical( <self>, <rel> ) . . . . . . . make a relator canonical1452**1453** 'FuncMakeCanonical' is a subroutine of the Reduced Reidemeister-Schreier1454** routines. It replaces the given relator by its canonical representative.1455** It does not return anything.1456*/1457Obj FuncMakeCanonical (1458Obj self,1459Obj rel ) /* the given relator */1460{1461Obj * ptRel; /* pointer to the relator */1462Obj obj1, obj2; /* handles 0f relator entries */1463Int leng, leng1; /* length of the relator */1464Int max, min, next; /* relator entries */1465Int i, j, k, l; /* integer variables */1466Int ii, jj, kk; /* integer variables */14671468/* Get and check the argument */1469if ( ! IS_PLIST(rel) ) {1470ErrorQuit( "<rel> must be a plain list (not a %s)",1471(Int)TNAM_OBJ(rel), 0L );1472return 0;1473}1474ptRel = &(ELM_PLIST(rel,1));1475leng = LEN_PLIST(rel);1476leng1 = leng - 1;14771478/* cyclically reduce the relator, if necessary */1479i = 0;1480while ( i<leng1 && INT_INTOBJ(ptRel[i]) == -INT_INTOBJ(ptRel[leng1]) ) {1481i++;1482leng1--;1483}1484if ( i > 0 ) {1485for ( j = i; j <= leng1; j++ ) {1486ptRel[j-i] = ptRel[j];1487}1488leng1 = leng1 - i;1489leng = leng1 + 1;1490SET_LEN_PLIST( rel, leng );1491}14921493/* Loop over the relator and find the maximal postitve and negative */1494/* entries */1495max = min = INT_INTOBJ(ptRel[0]);1496i = 0; j = 0;1497for ( k = 1; k < leng; k++ ) {1498next = INT_INTOBJ( ptRel[k] );1499if ( next > max ) {1500max = next;1501i = k;1502}1503else if ( next <= min ) {1504min = next;1505j = k;1506}1507}15081509/* Find the lexicographically last cyclic permutation of the relator */1510if ( max < -min ) {1511i = leng;1512}1513else {1514for ( k = i + 1; k < leng; k++ ) {1515for ( ii = i, kk = k, l = 0;1516l < leng;1517ii = (ii + 1) % leng, kk = (kk + 1) % leng, l++ )1518{1519if ( INT_INTOBJ(ptRel[kk]) < INT_INTOBJ(ptRel[ii]) ) {1520break;1521}1522else if ( INT_INTOBJ(ptRel[kk]) > INT_INTOBJ(ptRel[ii]) ) {1523i = k;1524break;1525}1526}1527if ( l == leng ) {1528break;1529}1530}1531}15321533/* Find the lexicographically last cyclic permutation of its inverse */1534if ( -max < min ) {1535j = leng;1536}1537else {1538for ( k = j - 1; k >= 0; k-- ) {1539for ( jj = j, kk = k, l = 0;1540l < leng;1541jj = (jj + leng1) % leng, kk = (kk + leng1) % leng, l++ )1542{1543if ( INT_INTOBJ(ptRel[kk]) > INT_INTOBJ(ptRel[jj]) ) {1544break;1545}1546else if ( INT_INTOBJ(ptRel[kk]) < INT_INTOBJ(ptRel[jj]) ) {1547j = k;1548break;1549}1550}1551if ( l == leng ) {1552break;1553}1554}1555}15561557/* Compare the two words and find the lexicographically last one */1558if ( -min == max ) {1559for ( ii = i, jj = j, l = 0;1560l < leng;1561ii = (ii + 1) % leng, jj = (jj + leng1) % leng, l++ )1562{1563if ( - INT_INTOBJ(ptRel[jj]) < INT_INTOBJ(ptRel[ii]) ) {1564break;1565}1566else if ( - INT_INTOBJ(ptRel[jj]) > INT_INTOBJ(ptRel[ii]) ) {1567i = leng;1568break;1569}1570}1571}15721573/* Invert the given relator, if necessary */1574if ( i == leng ) {1575for ( k = 0; k < leng / 2; k++ ) {1576next = INT_INTOBJ( ptRel[k] );1577ptRel[k] = INTOBJ_INT( - INT_INTOBJ( ptRel[leng1-k] ) );1578ptRel[leng1-k] = INTOBJ_INT( - next );1579}1580if ( leng % 2 ) {1581ptRel[leng1/2] = INTOBJ_INT( - INT_INTOBJ( ptRel[leng1/2] ) );1582}1583i = leng1 - j;1584}15851586/* Now replace the given relator by the resulting word */1587if ( i > 0 ) {1588k = INT_INTOBJ( GcdInt( INTOBJ_INT(i), INTOBJ_INT(leng) ) );1589l = leng / k;1590leng1 = leng - i;1591for ( j = 0; j < k; j++ ) {1592jj = (j + i) % leng;1593obj1 = ptRel[jj];1594for ( ii = 0; ii < l; ii++ ) {1595jj = (jj + leng1) % leng;1596obj2 = ptRel[jj]; ptRel[jj] = obj1; obj1 = obj2;1597}1598}1599}16001601/* return nothing */1602return 0;1603}160416051606/****************************************************************************1607**1608*F FuncTreeEntry( <self>, <tree>, <word> ) . tree entry for the given word1609**1610** 'FuncTreeEntry' determines a tree entry which represents the given word1611** in the current generators, if it finds any, or it defines a new proper1612** tree entry, and then returns it.1613*/1614Obj FuncTreeEntry(1615Obj self,1616Obj tree,1617Obj word )1618{1619Obj * ptTree1; /* pointer to that component */1620Obj * ptTree2; /* pointer to that component */1621Obj * ptWord; /* pointer to that word */1622Obj new; /* handle of new word */1623Obj * ptNew; /* pointer to new word */1624Obj * ptFac; /* pointer to old word */1625Int treesize; /* tree size */1626Int numgens; /* tree length */1627Int leng; /* word length */1628Int sign; /* integer variable */1629Int i, j, k; /* integer variables */1630Int gen; /* generator value */1631Int u, u1, u2; /* generator values */1632Int v, v1, v2; /* generator values */1633Int t1, t2; /* generator values */1634Int uabs, vabs; /* generator values */16351636/* Get and check the first argument (tree) */1637objTree = tree;1638if ( ! IS_PLIST(tree) || LEN_PLIST(tree) < 5 ) {1639ErrorQuit( "invalid <tree>", 0L, 0L );1640return 0;1641}16421643/* Get and check the tree components */1644objTree1 = ELM_PLIST(objTree,1);1645if ( ! IS_PLIST(objTree1) ) {1646ErrorQuit( "invalid <tree>[1]", 0L, 0L );1647return 0;1648}1649objTree2 = ELM_PLIST(objTree,2);1650if ( ! IS_PLIST(objTree2) ) {1651ErrorQuit( "invalid <tree>[2]", 0L, 0L );1652return 0;1653}1654ptTree1 = &(ELM_PLIST(objTree1,1)) - 1;1655ptTree2 = &(ELM_PLIST(objTree2,1)) - 1;1656treesize = LEN_PLIST(objTree1);1657numgens = INT_INTOBJ( ELM_PLIST( objTree, 3 ) );1658treeWordLength = INT_INTOBJ( ELM_PLIST( objTree, 4 ) );1659treeType = INT_INTOBJ( ELM_PLIST( objTree, 5 ) );16601661/* Get the second argument (word) */1662if ( ! IS_PLIST(word) ) {1663ErrorQuit( "invalid <word>", 0L, 0L );1664return 0;1665}16661667/* handle the abelianized case */1668ptWord = &(ELM_PLIST(word,1)) - 1;1669if ( treeType == 0 ) {1670if ( LEN_PLIST(word) != treeWordLength ) {1671ErrorQuit( "inconsistent <word> length", 0L, 0L );1672return 0;1673}1674ptWord = &(ELM_PLIST(objTree2,1)) - 1;1675for ( leng = treeWordLength; leng >= 1; leng-- ) {1676if ( ptWord[leng] != INTOBJ_INT(0) ) {1677break;1678}1679}1680if ( leng == 0 ) {1681return INTOBJ_INT( 0 );1682}16831684for ( k = 1; k <= leng; k++ ) {1685if ( ptWord[k] != INTOBJ_INT(0) ) {1686break;1687}1688}1689sign = 1;16901691/* invert the word */1692if ( INT_INTOBJ(ptWord[k]) < 0 ) {1693sign = -1;1694for ( i = k; i <= leng; i++ ) {1695ptWord[i] = INTOBJ_INT( - INT_INTOBJ( ptWord[i] ) );1696}1697}16981699for ( k = 1; k <= numgens; k++ ) {1700ptFac = &(ELM_PLIST(ptTree1[k],1)) - 1;1701if ( LEN_PLIST(ptTree1[k]) == leng ) {1702for ( i = 1; i <= leng; i++ ) {1703if ( ptFac[i] != ptWord[i] ) {1704break;1705}1706}1707if ( i > leng ) {1708return INTOBJ_INT( sign * k );1709}1710}1711}17121713/* extend the tree */1714numgens++;1715if ( treesize < numgens ) {1716treesize = 2 * treesize;1717GROW_PLIST( objTree1, treesize );1718SET_LEN_PLIST( objTree1, treesize );1719CHANGED_BAG(objTree);1720}1721new = NEW_PLIST( T_PLIST, leng );1722SET_LEN_PLIST( new, leng );17231724SET_ELM_PLIST( objTree, 3, INTOBJ_INT(numgens) );1725SET_ELM_PLIST( objTree1, numgens, new );1726CHANGED_BAG(objTree1);17271728/* copy the word to the new bag */1729ptWord = &(ELM_PLIST(objTree2,1)) - 1;1730ptNew = &(ELM_PLIST(new,1)) - 1;1731while ( leng > 0 ) {1732ptNew[leng] = ptWord[leng];1733leng--;1734}17351736return INTOBJ_INT( sign * numgens );1737}17381739/* handle the general case */1740if ( LEN_PLIST(objTree1) != LEN_PLIST(objTree2) ) {1741ErrorQuit( "inconsistent <tree> components", 0L, 0L );1742return 0;1743}17441745for ( i = 1; i <= numgens; i++ ) {1746if ( INT_INTOBJ(ptTree1[i]) <= -i || INT_INTOBJ(ptTree1[i]) >= i1747|| INT_INTOBJ(ptTree2[i]) <= -i || INT_INTOBJ(ptTree2[i]) >= i )1748{1749ErrorQuit( "invalid <tree> components", 0L, 0L );1750return 0;1751}1752}17531754/* Freely reduce the given word */1755leng = LEN_PLIST(word);1756for ( j = 0, i = 1; i <= leng; i++ ) {1757gen = INT_INTOBJ(ptWord[i]);1758if ( gen == 0 ) {1759continue;1760}1761if ( gen > numgens || gen < -numgens ) {1762ErrorQuit( "invalid <word> entry [%d]", i, 0L );1763return 0;1764}1765if ( j > 0 && gen == - INT_INTOBJ(ptWord[j]) ) {1766j--;1767}1768else {1769ptWord[++j] = ptWord[i];1770}1771}1772for ( i = j + 1; i <= leng; i++ ) {1773ptWord[i] = INTOBJ_INT( 0 );1774}1775leng = j;17761777gen = ( leng == 0 ) ? 0 : INT_INTOBJ( ptWord[1] );1778u2 = 0; /* just to shut up gcc */1779for ( i = 2; i <= leng; i++ ) {1780u = gen;1781v = INT_INTOBJ( ELM_PLIST(word,i) );1782while ( i ) {17831784/* First handle the trivial cases */1785if ( u == 0 || v == 0 || ( u + v ) == 0 ) {1786gen = u + v;1787break;1788}17891790/* Cancel out factors, if possible */1791u1 = INT_INTOBJ( ptTree1[ (u > 0) ? u : -u ] );1792if ( u1 != 0 ) {1793if ( u > 0 ) {1794u2 = INT_INTOBJ( ptTree2[u] );1795}1796else {1797u2 = - u1;1798u1 = - INT_INTOBJ( ptTree2[-u] );1799}1800if ( u2 == -v ) {1801gen = u1;1802break;1803}1804}1805v1 = INT_INTOBJ( ptTree1[ (v > 0) ? v : -v ] );1806if ( v1 != 0 ) {1807if ( v > 0 ) {1808v2 = INT_INTOBJ( ptTree2[v] );1809}1810else {1811v2 = - v1;1812v1 = - INT_INTOBJ( ptTree2[-v] );1813}1814if ( v1 == -u ) {1815gen = v2;1816break;1817}1818if ( u1 != 0 && v1 == - u2 ) {1819u = u1;1820v = v2;1821continue;1822}1823}18241825/* Check if there is already a tree entry [u,v] or [-v,-u] */1826if ( u < -v ) {1827t1 = u;1828t2 = v;1829}1830else {1831t1 = -v;1832t2 = -u;1833}1834uabs = ( u > 0 ) ? u : -u;1835vabs = ( v > 0 ) ? v : -v;1836k = ( uabs > vabs ) ? uabs : vabs;1837for ( k++; k <= numgens; k++ ) {1838if ( INT_INTOBJ(ptTree1[k]) == t1 &&1839INT_INTOBJ(ptTree2[k]) == t2 )1840{1841break;1842}1843}18441845/* Extend the tree, if necessary */1846if ( k > numgens ) {1847numgens++;1848if ( treesize < numgens ) {1849treesize = 2 * treesize;1850GROW_PLIST( objTree1, treesize );1851GROW_PLIST( objTree2, treesize );1852SET_LEN_PLIST( objTree1, treesize );1853SET_LEN_PLIST( objTree2, treesize );1854ptTree1 = &(ELM_PLIST(objTree1,1)) - 1;1855ptTree2 = &(ELM_PLIST(objTree2,1)) - 1;1856CHANGED_BAG(objTree);1857}1858ptTree1[numgens] = INTOBJ_INT( t1 );1859ptTree2[numgens] = INTOBJ_INT( t2 );1860SET_ELM_PLIST( objTree, 3, INTOBJ_INT( numgens ) );1861}1862gen = ( u > - v ) ? -k : k;1863break;1864}1865}18661867return INTOBJ_INT( gen );1868}186918701871/****************************************************************************1872**1873*F AddCosetFactor( <factor> ) . . . . . . . . . . . . add a coset rep factor1874**1875** 'AddCosetFactor' adds a factor to a coset representative word by changing1876** its exponent appropriately.1877**1878** 'treeType', 'objWordValue', and 'objExponent' are assumed to be known as1879** static variables, and 'treeType' is assumed to be 1.1880**1881** Warning: 'factor' is not checked for being zero.1882*/1883static void AddCosetFactor (1884Obj factor )1885{1886/* handle the one generator MTC case */1887objWordValue = SumInt( objWordValue, factor );1888if ( objExponent != INTOBJ_INT(0) ) {1889objWordValue = RemInt( objWordValue, objExponent );1890}1891}189218931894/****************************************************************************1895**1896*F SubtractCosetFactor( <factor> ) . . . . . . subtract a coset rep factor1897**1898** 'SubtractCosetFactor' subtracts a factor from a coset representative word1899** by changing its exponent appropriately.1900**1901** 'treeType', 'objWordValue', and 'objExponent' are assumed to be known as1902** static variables, and 'treeType' is assumed to be 1.1903**1904** Warning: 'factor' is not checked for being zero.1905*/1906static void SubtractCosetFactor (1907Obj factor )1908{1909/* handle the one generator MTC case */1910objWordValue = DiffInt( objWordValue, factor );1911if ( objExponent != INTOBJ_INT(0) ) {1912objWordValue = RemInt( objWordValue, objExponent );1913}1914}191519161917/****************************************************************************1918**1919*F HandleCoinc2( <cos1>, <cos2>, <factor> ) . handle coincidences in an MTC1920**1921** 'HandleCoinc2' is a subroutine of 'FuncMakeConsequences2' and handles the1922** coincidence cos2 = factor * cos1.1923*/1924static void HandleCoinc2 (1925Int cos1,1926Int cos2,1927Obj factor )1928{1929Obj f, ff2; /* handles of temporary factors */1930Obj f1, f2; /* handles of temporary factors */1931Obj rem; /* handle of remainder */1932Obj tmp; /* temporary variable */1933Obj * gen2;1934Obj * gen;1935Obj * inv2;1936Obj * inv;1937Obj * ptNext;1938Obj * ptPrev;1939Int c1, c2;1940Int firstCoinc;1941Int i, j; /* loop variables */1942Int lastCoinc;1943Int length; /* length of coset rep word */1944Int save; /* temporary factor */19451946/* return, if cos1 = cos2 */1947if ( cos1 == cos2 ) {19481949/* but pick up a relator before in case treeType = 1 */1950if ( treeType == 1 && factor != INTOBJ_INT(0) ) {1951if ( objExponent == INTOBJ_INT(0) ) {1952objExponent = factor;1953}1954else {1955rem = RemInt( factor, objExponent );1956while ( rem != INTOBJ_INT(0) ) {1957factor = objExponent;1958objExponent = rem;1959rem = RemInt( factor, objExponent );1960}1961}1962}1963return;1964}19651966/* take the smaller one as new representative */1967if ( cos2 < cos1 ) {1968save = cos1; cos1 = cos2; cos2 = save;1969factor = ( treeType == 1 ) ?1970DiffInt( INTOBJ_INT(0), factor ) :1971INTOBJ_INT( -INT_INTOBJ(factor) );1972}19731974/* get some pointers */1975ptNext = &(ELM_PLIST(objNext,1)) - 1;1976ptPrev = &(ELM_PLIST(objPrev,1)) - 1;19771978/* if we are removing an important coset update it */1979if ( cos2 == lastDef ) {1980lastDef = INT_INTOBJ( ptPrev[lastDef ] );1981}1982if ( cos2 == firstDef ) {1983firstDef = INT_INTOBJ( ptPrev[firstDef] );1984}19851986/* remove <cos2> from the coset list */1987ptNext[INT_INTOBJ(ptPrev[cos2])] = ptNext[cos2];1988if ( ptNext[cos2] != INTOBJ_INT(0) ) {1989ptPrev[INT_INTOBJ(ptNext[cos2])] = ptPrev[cos2];1990}19911992/* put the first coincidence into the list of coincidences */1993firstCoinc = cos2;1994lastCoinc = cos2;1995ptNext[lastCoinc] = INTOBJ_INT(0);19961997/* <cos1> is the representative of <cos2> and its own representative */1998ptPrev[cos2] = INTOBJ_INT(cos1);1999SET_ELM_PLIST( objFactor, cos2, factor );20002001/* while there are coincidences to handle */2002while ( firstCoinc != 0 ) {20032004/* replace <firstCoinc> by its representative in the table */2005cos2 = firstCoinc;2006cos1 = INT_INTOBJ( ELM_PLIST( objPrev, cos2 ) );2007factor = ELM_PLIST( objFactor, cos2 );2008for ( i = 1; i <= LEN_PLIST(objTable); i++ ) {2009j = i + 2*(i % 2) - 1;20102011/* replace <cos2> by <cos1> in the column of <gen>^-1 */2012gen = &(ELM_PLIST(ELM_PLIST(objTable,i),1)) - 1;2013gen2 = &(ELM_PLIST(ELM_PLIST(objTable2,i),1)) - 1;2014c2 = INT_INTOBJ(gen[cos2]);2015if ( c2 != 0 ) {2016f2 = gen2[cos2];2017c1 = INT_INTOBJ(gen[cos1]);20182019/* if the other entry is empty copy it */2020if ( c1 == 0 ) {2021if ( f2 == factor ) {2022ff2 = INTOBJ_INT(0);2023}2024else {2025if ( treeType == 1 ) {2026objWordValue = INTOBJ_INT(0);2027if ( factor != INTOBJ_INT(0) ) {2028SubtractCosetFactor(factor);2029}2030if ( f2 != INTOBJ_INT(0) ) {2031AddCosetFactor( f2 );2032}2033ff2 = objWordValue;2034}2035else {2036InitializeCosetFactorWord();2037if ( factor != INTOBJ_INT(0) ) {2038AddCosetFactor2( -INT_INTOBJ(factor) );2039}2040if ( f2 != INTOBJ_INT(0) ) {2041AddCosetFactor2( INT_INTOBJ(f2) );2042}2043ff2 = INTOBJ_INT(TreeEntryC());2044}2045}2046tmp = ( treeType == 1 ) ?2047DiffInt( INTOBJ_INT(0), ff2 ) :2048INTOBJ_INT( -INT_INTOBJ(ff2) );2049gen = &(ELM_PLIST(ELM_PLIST(objTable,i),1)) - 1;2050gen2 = &(ELM_PLIST(ELM_PLIST(objTable2,i),1)) - 1;2051inv = &(ELM_PLIST(ELM_PLIST(objTable,j),1)) - 1;2052inv2 = &(ELM_PLIST(ELM_PLIST(objTable2,j),1)) - 1;2053gen[cos1] = INTOBJ_INT(c2);2054gen2[cos1] = ff2;2055gen[cos2] = INTOBJ_INT(0);2056gen2[cos2] = INTOBJ_INT(0);2057inv[c2] = INTOBJ_INT(cos1);2058inv2[c2] = tmp;2059if ( dedlst == dedSize ) {2060CompressDeductionList();2061}2062dedgen[dedlst] = i;2063dedcos[dedlst] = cos1;2064dedlst++;2065}20662067/* otherwise check for a coincidence */2068else {2069f1 = gen2[cos1];2070inv = &(ELM_PLIST(ELM_PLIST(objTable,j),1)) - 1;2071inv2 = &(ELM_PLIST(ELM_PLIST(objTable2,j),1)) - 1;2072inv[c2] = INTOBJ_INT(0);2073inv2[c2] = INTOBJ_INT(0);2074gen[cos2] = INTOBJ_INT(0);2075gen2[cos2] = INTOBJ_INT(0);20762077/* if gen = inv and c2 = cos1, reset the table entries */2078if ( gen[cos1] == INTOBJ_INT(0) ) {2079if ( f2 == factor ) {2080ff2 = INTOBJ_INT(0);2081}2082else {2083if ( treeType == 1 ) {2084objWordValue = INTOBJ_INT(0);2085if ( factor != INTOBJ_INT(0) ) {2086SubtractCosetFactor(factor);2087}2088if ( f2 != INTOBJ_INT(0) ) {2089AddCosetFactor(f2);2090}2091ff2 = objWordValue;2092}2093else {2094InitializeCosetFactorWord();2095if ( factor != INTOBJ_INT(0) ) {2096AddCosetFactor2( -INT_INTOBJ(factor) );2097}2098if ( f2 != INTOBJ_INT(0) ) {2099AddCosetFactor2( INT_INTOBJ(f2) );2100}2101ff2 = INTOBJ_INT( TreeEntryC() );2102}2103gen = &(ELM_PLIST(ELM_PLIST(objTable,i),1))-1;2104gen2 = &(ELM_PLIST(ELM_PLIST(objTable2,i),1))-1;2105}2106gen[cos1] = INTOBJ_INT(cos1);2107gen2[cos1] = ff2;2108if ( dedlst == dedSize ) {2109CompressDeductionList();2110}2111dedgen[dedlst] = i;2112dedcos[dedlst] = cos1;2113dedlst++;2114}21152116/* initialize the factor for the new coincidence */2117InitializeCosetFactorWord();21182119/* find the representative of <c2> */21202121/* handle the one generator MTC case */2122if ( treeType == 1 ) {21232124if ( f2 != INTOBJ_INT(0) ) {2125SubtractCosetFactor(f2);2126}2127while ( c2 != 1 && INT_INTOBJ( ELM_PLIST( objNext,2128INT_INTOBJ(ELM_PLIST(objPrev,c2)))) != c2 )2129{2130f2 = ELM_PLIST(objFactor,c2);2131c2 = INT_INTOBJ( ELM_PLIST(objPrev,c2) );2132if ( f2 != INTOBJ_INT(0) ) {2133SubtractCosetFactor(f2);2134}2135}2136if ( factor != INTOBJ_INT(0) ) {2137AddCosetFactor(factor);2138}2139if ( f1 != INTOBJ_INT(0) ) {2140AddCosetFactor(f1);2141}2142}21432144/* handle the abelianized case */2145else if ( treeType == 0 ) {2146if ( f2 != INTOBJ_INT(0) ) {2147AddCosetFactor2( -INT_INTOBJ(f2) );2148}2149while ( c2 != 1 && INT_INTOBJ( ELM_PLIST( objNext,2150INT_INTOBJ(ELM_PLIST(objPrev,c2)))) != c2 )2151{2152f2 = ELM_PLIST(objFactor,c2);2153c2 = INT_INTOBJ( ELM_PLIST(objPrev,c2) );2154if ( f2 != INTOBJ_INT(0) ) {2155AddCosetFactor2( -INT_INTOBJ(f2) );2156}2157}2158if ( factor != INTOBJ_INT(0) ) {2159AddCosetFactor2( INT_INTOBJ(factor) );2160}2161if ( f1 != INTOBJ_INT(0) ) {2162AddCosetFactor2( INT_INTOBJ(f1) );2163}2164}21652166/* handle the general case */2167else2168{2169if ( f2 != INTOBJ_INT(0) ) {2170AddCosetFactor2( INT_INTOBJ(f2) );2171}2172while ( c2 != 1 && INT_INTOBJ( ELM_PLIST( objNext,2173INT_INTOBJ(ELM_PLIST(objPrev,c2)))) != c2 )2174{2175f2 = ELM_PLIST(objFactor,c2);2176c2 = INT_INTOBJ( ELM_PLIST(objPrev,c2) );2177if ( f2 != INTOBJ_INT(0) ) {2178AddCosetFactor2( INT_INTOBJ(f2) );2179}2180}21812182/* invert the word constructed so far */2183if ( wordList[0] > 0 ) {2184length = wordList[0] + 1;2185for ( i = length / 2; i > 0; i-- ) {2186save = wordList[i];2187wordList[i] = - wordList[length-i];2188wordList[length-i] = - save;2189}2190}2191if ( factor != INTOBJ_INT(0) ) {2192AddCosetFactor2( INT_INTOBJ(factor) );2193}2194if ( f1 != INTOBJ_INT(0) ) {2195AddCosetFactor2( INT_INTOBJ(f1) );2196}2197}21982199/* find the representative of <c1> */2200while ( c1 != 1 && INT_INTOBJ( ELM_PLIST( objNext,2201INT_INTOBJ(ELM_PLIST(objPrev,c1)))) != c1 )2202{2203f1 = ELM_PLIST(objFactor,c1);2204c1 = INT_INTOBJ( ELM_PLIST(objPrev,c1) );2205if ( f1 != INTOBJ_INT(0) ) {2206if ( treeType == 1 ) {2207AddCosetFactor( f1 );2208}2209else {2210AddCosetFactor2( INT_INTOBJ(f1) );2211}2212}2213}22142215/* if the representatives differ we got a coincidence */2216if ( c1 != c2 ) {22172218/* get the quotient of c2 by c1 */2219f = (treeType == 1 ) ?2220objWordValue : INTOBJ_INT(TreeEntryC());22212222/* take the smaller one as new representative */2223if ( c2 < c1 ) {2224save = c1; c1 = c2; c2 = save;2225f = ( treeType == 1 ) ?2226DiffInt( INTOBJ_INT(0), f ) :2227INTOBJ_INT( -INT_INTOBJ(f) );2228}22292230/* get some pointers */2231ptNext = &(ELM_PLIST(objNext,1)) - 1;2232ptPrev = &(ELM_PLIST(objPrev,1)) - 1;22332234/* if we are removing an important coset update it */2235if ( c2 == lastDef ) {2236lastDef = INT_INTOBJ(ptPrev[lastDef]);2237}2238if ( c2 == firstDef ) {2239firstDef = INT_INTOBJ(ptPrev[firstDef]);2240}22412242/* remove <c2> from the coset list */2243ptNext[INT_INTOBJ(ptPrev[c2])] = ptNext[c2];2244if ( ptNext[c2] != INTOBJ_INT(0) ) {2245ptPrev[INT_INTOBJ(ptNext[c2])] = ptPrev[c2];2246}22472248/* append <c2> to the coincidence list */2249ptNext[lastCoinc] = INTOBJ_INT(c2);2250lastCoinc = c2;2251ptNext[lastCoinc] = INTOBJ_INT(0);22522253/* <c1> is the rep of <c2> and its own rep. */2254ptPrev[c2] = INTOBJ_INT( c1 );2255SET_ELM_PLIST( objFactor, c2, f );2256}22572258/* pick up a relator in case treeType = 1 */2259else if ( treeType == 1 ) {2260f = objWordValue;2261if ( f != INTOBJ_INT(0) ) {2262if ( objExponent == INTOBJ_INT(0) ) {2263objExponent = f;2264}2265else {2266rem = RemInt( f, objExponent );2267while ( rem != INTOBJ_INT(0) ) {2268f = objExponent;2269objExponent = rem;2270rem = RemInt( f, objExponent );2271}2272}2273}2274}2275}2276}2277}22782279/* move the replaced coset to the free list */2280ptNext = &(ELM_PLIST(objNext,1)) - 1;2281if ( firstFree == 0 ) {2282firstFree = firstCoinc;2283lastFree = firstCoinc;2284}2285else {2286ptNext[lastFree] = INTOBJ_INT(firstCoinc);2287lastFree = firstCoinc;2288}2289firstCoinc = INT_INTOBJ( ptNext[firstCoinc] );2290ptNext[lastFree] = INTOBJ_INT(0);22912292nrdel++;2293}2294}229522962297/****************************************************************************2298**2299*F FuncMakeConsequences2( <self>, <list> ) . . . . . . . find consequences2300*/2301Obj FuncMakeConsequences2 (2302Obj self,2303Obj list )2304{2305Obj subs; /* */2306Obj rels; /* */2307Obj * ptRel; /* pointer to the relator bag */2308Int lp; /* left pointer into relator */2309Int lc; /* left coset to apply to */2310Int rp; /* right pointer into relator */2311Int rc; /* right coset to apply to */2312Int tc; /* temporary coset */2313Int length; /* length of coset rep word */2314Obj objNum; /* handle of temporary factor */2315Obj objRep; /* handle of temporary factor */2316Int rep; /* temporary factor */2317Int i, j; /* loop variables */2318Obj tmp; /* temporary variable */23192320/* get the list of arguments */2321if ( ! IS_PLIST(list) ) {2322ErrorQuit( "<list> must be a plain list (not a %s)",2323(Int)TNAM_OBJ(list), 0L );2324return 0;2325}2326if ( LEN_PLIST(list) != 16 ) {2327ErrorQuit( "<list> must be a list of length 16", 0L, 0L );2328return 0;2329}23302331/* get the coset table, the corresponding factor table, the subgroup */2332/* generators tree, and its components */2333objTable = ELM_PLIST(list,1);2334objTable2 = ELM_PLIST(list,12);2335objTree = ELM_PLIST(list,14);2336objTree1 = ELM_PLIST(objTree,1);2337objTree2 = ELM_PLIST(objTree,2);2338treeType = INT_INTOBJ( ELM_PLIST(objTree,5) );2339treeWordLength = INT_INTOBJ( ELM_PLIST(list,15) );2340objExponent = ELM_PLIST(list,16);23412342objNext = ELM_PLIST(list,2);2343objPrev = ELM_PLIST(list,3);2344objFactor = ELM_PLIST(list,13);23452346firstFree = INT_INTOBJ( ELM_PLIST(list,6) );2347lastFree = INT_INTOBJ( ELM_PLIST(list,7) );2348firstDef = INT_INTOBJ( ELM_PLIST(list,8) );2349lastDef = INT_INTOBJ( ELM_PLIST(list,9) );23502351nrdel = 0;23522353/* initialize the deduction queue */2354dedprint = 0;2355dedfst = 0;2356dedlst = 1;2357dedgen[0] = INT_INTOBJ( ELM_PLIST(list,10) );2358dedcos[0] = INT_INTOBJ( ELM_PLIST(list,11) );23592360/* while the deduction queue is not empty */2361while ( dedfst < dedlst ) {23622363/* skip the deduction, if it got irrelevant by a coincidence */2364tmp = ELM_PLIST( objTable, dedgen[dedfst] );2365tmp = ELM_PLIST( tmp, dedcos[dedfst] );2366if ( INT_INTOBJ(tmp) == 0 ) {2367dedfst++;2368continue;2369}23702371/* while there are still subgroup generators apply them */2372subs = ELM_PLIST(list,5);2373for ( i = LEN_PLIST(subs); 1 <= i; i-- ) {2374if ( ELM_PLIST(subs,i) != 0 ) {2375tmp = ELM_PLIST(subs,i);2376objNums = ELM_PLIST(tmp,1);2377objRel = ELM_PLIST(tmp,2);2378ptRel = &(ELM_PLIST(objRel,1)) - 1;23792380lp = 2;2381lc = 1;2382rp = LEN_PLIST(objRel) - 1;2383rc = 1;23842385/* scan as long as possible from the left to the right */2386while ( lp < rp2387&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))) )2388{2389lc = tc;2390lp = lp + 2;2391}23922393/* scan as long as possible from the right to the left */2394while ( lp < rp2395&& 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))) )2396{2397rc = tc;2398rp = rp - 2;2399}24002401/* scan once more, but now with factors, if a coincidence or */2402/* a deduction has been found */2403if (lp == rp+1 && INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc) {2404lp = 2;2405lc = 1;2406rp = LEN_PLIST(objRel) - 1;2407rc = 1;24082409/* initialize the coset representative word */2410InitializeCosetFactorWord();24112412/* scan as long as possible from the left to the right */24132414/* handle the one generator MTC case */2415if ( treeType == 1 ) {2416while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2417ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )2418{2419objRep = ELM_PLIST(objNums,lp);2420objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2421objRep = ELM_PLIST(objRep,lc);2422if ( objRep != INTOBJ_INT(0) ) {2423SubtractCosetFactor(objRep);2424}2425lc = tc;2426lp = lp + 2;2427}24282429/* add the factor defined by the ith subgrp generator*/2430if ( i != 0 ) {2431AddCosetFactor( INTOBJ_INT(i) );2432}24332434/* scan as long as poss from the right to the left */2435while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2436ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )2437{2438objRep = ELM_PLIST(objNums,rp);2439objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2440objRep = ELM_PLIST(objRep,rc);2441if ( objRep != INTOBJ_INT(0) ) {2442AddCosetFactor(objRep);2443}2444rc = tc;2445rp = rp - 2;2446}2447}24482449/* handle the abelianized case */2450else if ( treeType == 0 ) {2451while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2452ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )2453{2454objRep = ELM_PLIST(objNums,lp);2455objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2456objRep = ELM_PLIST(objRep,lc);2457rep = INT_INTOBJ(objRep);2458if ( rep != 0 ) {2459AddCosetFactor2(-rep);2460}2461lc = tc;2462lp = lp + 2;2463}24642465/* add the factor defined by the ith subgrp generator*/2466if ( i != 0 ) {2467AddCosetFactor2(i);2468}24692470/* scan as long as poss from the right to the left */2471while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2472ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )2473{2474objRep = ELM_PLIST(objNums,rp);2475objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2476objRep = ELM_PLIST(objRep,rc);2477rep = INT_INTOBJ(objRep);2478if ( rep != 0 ) {2479AddCosetFactor2(rep);2480}2481rc = tc;2482rp = rp - 2;2483}2484}24852486/* handle the general case */2487else {2488while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2489ELM_PLIST(ELM_PLIST(objRel,lp),lc))) )2490{2491objRep = ELM_PLIST(objNums,lp);2492objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2493objRep = ELM_PLIST(objRep,lc);2494rep = INT_INTOBJ(objRep);2495if ( rep != 0 ) {2496AddCosetFactor2(rep);2497}2498lc = tc;2499lp = lp + 2;2500}25012502/* invert the word constructed so far */2503if ( wordList[0] > 0 ) {2504length = wordList[0] + 1;2505for ( j = length / 2; j > 0; j-- ) {2506rep = wordList[j];2507wordList[j] = - wordList[length-j];2508wordList[length-j] = - rep;2509}2510}25112512/* add the factor defined by the ith subgrp generator*/2513if ( i != 0 ) {2514AddCosetFactor2(i);2515}25162517/* scan as long as poss from the right to the left */2518while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ(2519ELM_PLIST(ELM_PLIST(objRel,rp),rc))) )2520{2521objRep = ELM_PLIST(objNums,rp);2522objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2523objRep = ELM_PLIST(objRep,rc);2524rep = INT_INTOBJ(objRep);2525if ( rep != 0 ) {2526AddCosetFactor2(rep);2527}2528rc = tc;2529rp = rp - 2;2530}2531}25322533/* enter the word into the tree and return its number */2534objNum = ( treeType == 1 ) ?2535objWordValue : INTOBJ_INT(TreeEntryC());25362537/* work off a coincidence */2538if ( lp >= rp + 2 ) {2539HandleCoinc2( rc, lc, objNum );2540}25412542/* enter a decuction to the tables */2543else {2544objRep = ELM_PLIST(objRel,lp);2545SET_ELM_PLIST( objRep, lc, INTOBJ_INT(rc) );25462547objRep = ELM_PLIST(objNums,lp);2548objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2549SET_ELM_PLIST( objRep, lc, objNum );25502551objRep = ELM_PLIST(objRel,rp);2552SET_ELM_PLIST( objRep, rc, INTOBJ_INT(lc) );25532554tmp = ( treeType == 1 ) ?2555DiffInt( INTOBJ_INT(0), objNum ) :2556INTOBJ_INT( -INT_INTOBJ( objNum ) );2557objRep = ELM_PLIST(objNums,rp);2558objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2559SET_ELM_PLIST( objRep, rc, tmp );25602561if ( dedlst == dedSize ) {2562CompressDeductionList();2563}2564dedgen[dedlst] = INT_INTOBJ( ELM_PLIST(objNums,lp) );2565dedcos[dedlst] = lc;2566dedlst++;2567}25682569/* remove the completed subgroup generator */2570SET_ELM_PLIST( subs, i, 0 );2571if ( i == LEN_PLIST(subs) ) {2572while ( 0 < i && ELM_PLIST(subs,i) == 0 ) {2573--i;2574}2575SET_LEN_PLIST( subs, i );2576}2577}2578}2579}25802581/* apply all relators that start with this generator */2582rels = ELM_PLIST( ELM_PLIST(list,4), dedgen[dedfst] );2583for ( i = 1; i <= LEN_PLIST(rels); i++ ) {2584tmp = ELM_PLIST(rels,i);2585objNums = ELM_PLIST(tmp,1);2586objRel = ELM_PLIST(tmp,2);2587ptRel = &(ELM_PLIST(objRel,1)) - 1;25882589lp = INT_INTOBJ( ELM_PLIST(tmp,3) );2590lc = dedcos[dedfst];2591rp = lp + INT_INTOBJ(ptRel[1]);2592rc = lc;25932594/* scan as long as possible from the left to the right */2595while (lp < rp && 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[lp],lc))))2596{2597lc = tc;2598lp = lp + 2;2599}26002601/* scan as long as possible from the right to the left */2602while (lp < rp && 0 < (tc = INT_INTOBJ(ELM_PLIST(ptRel[rp],rc))))2603{2604rc = tc;2605rp = rp - 2;2606}26072608/* scan once more, but now with factors, if a coincidence or a */2609/* deduction has been found */2610if ( lp == rp+1 && ( INT_INTOBJ(ELM_PLIST(ptRel[lp],lc)) != rc2611|| treeType == 1 ) )2612{26132614lp = INT_INTOBJ( ELM_PLIST( ELM_PLIST(rels,i), 3 ) );2615lc = dedcos[dedfst];2616rp = lp + INT_INTOBJ(ptRel[1]);2617rc = lc;26182619/* initialize the coset representative word */2620InitializeCosetFactorWord();26212622/* scan as long as possible from the left to the right */2623/* handle the one generator MTC case */26242625if ( treeType == 1 ) {26262627while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2628ELM_PLIST(objRel,lp),lc))) )2629{2630objRep = ELM_PLIST(objNums,lp);2631objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2632objRep = ELM_PLIST(objRep,lc);2633if ( objRep != INTOBJ_INT(0) ) {2634SubtractCosetFactor(objRep);2635}2636lc = tc;2637lp = lp + 2;2638}26392640/* scan as long as possible from the right to the left */2641while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2642ELM_PLIST(objRel,rp),rc))) )2643{2644objRep = ELM_PLIST(objNums,rp);2645objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2646objRep = ELM_PLIST(objRep,rc);2647if ( objRep != INTOBJ_INT(0) ) {2648AddCosetFactor( objRep );2649}2650rc = tc;2651rp = rp - 2;2652}2653}26542655/* handle the abelianized case */2656else if ( treeType == 0 ) {2657while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2658ELM_PLIST(objRel,lp),lc))) )2659{2660objRep = ELM_PLIST(objNums,lp);2661objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2662objRep = ELM_PLIST(objRep,lc);2663rep = INT_INTOBJ(objRep);2664if ( rep != 0 ) {2665AddCosetFactor2(-rep);2666}2667lc = tc;2668lp = lp + 2;2669}26702671/* scan as long as possible from the right to the left */2672while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2673ELM_PLIST(objRel,rp),rc))) )2674{2675objRep = ELM_PLIST(objNums,rp);2676objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2677objRep = ELM_PLIST(objRep,rc);2678rep = INT_INTOBJ(objRep);2679if ( rep != 0 ) {2680AddCosetFactor2(rep);2681}2682rc = tc;2683rp = rp - 2;2684}2685}26862687/* handle the general case */2688else {2689while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2690ELM_PLIST(objRel,lp),lc))) )2691{2692objRep = ELM_PLIST(objNums,lp);2693objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2694objRep = ELM_PLIST(objRep,lc);2695rep = INT_INTOBJ(objRep);2696if ( rep != 0 ) {2697AddCosetFactor2(rep);2698}2699lc = tc;2700lp = lp + 2;2701}27022703/* invert the word constructed so far */2704if ( wordList[0] > 0 ) {2705length = wordList[0] + 1;2706for ( j = length / 2; j > 0; j-- ) {2707rep = wordList[j];2708wordList[j] = - wordList[length-j];2709wordList[length-j] = - rep;2710}2711}27122713/* scan as long as possible from the right to the left */2714while ( lp < rp + 2 && 0 < (tc = INT_INTOBJ( ELM_PLIST(2715ELM_PLIST(objRel,rp),rc))) )2716{2717objRep = ELM_PLIST(objNums,rp);2718objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2719objRep = ELM_PLIST(objRep,rc);2720rep = INT_INTOBJ(objRep);2721if ( rep != 0 ) {2722AddCosetFactor2( rep );2723}2724rc = tc;2725rp = rp - 2;2726}2727}27282729/* enter the word into the tree and return its number */2730objNum = ( treeType == 1 ) ?2731objWordValue : INTOBJ_INT(TreeEntryC());27322733/* work off a coincidence */2734if ( lp >= rp + 2 ) {2735HandleCoinc2( rc, lc, objNum );2736}27372738/* enter a decuction to the tables */2739else {2740objRep = ELM_PLIST(objRel,lp);2741SET_ELM_PLIST( objRep, lc, INTOBJ_INT(rc) );27422743objRep = ELM_PLIST(objNums,lp);2744objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2745SET_ELM_PLIST( objRep, lc, objNum );27462747objRep = ELM_PLIST(objRel,rp);2748SET_ELM_PLIST( objRep, rc, INTOBJ_INT(lc) );27492750tmp = ( treeType == 1 ) ?2751DiffInt( INTOBJ_INT(0), objNum ) :2752INTOBJ_INT( -INT_INTOBJ(objNum) );2753objRep = ELM_PLIST(objNums,rp);2754objRep = ELM_PLIST(objTable2,INT_INTOBJ(objRep));2755SET_ELM_PLIST( objRep, rc, tmp );27562757if ( dedlst == dedSize ) {2758CompressDeductionList();2759}2760dedgen[dedlst] = INT_INTOBJ( ELM_PLIST(objNums,lp) );2761dedcos[dedlst] = lc;2762dedlst++;2763}27642765}27662767}2768dedfst++;2769}27702771SET_ELM_PLIST( list, 6, INTOBJ_INT(firstFree) );2772SET_ELM_PLIST( list, 7, INTOBJ_INT(lastFree) );2773SET_ELM_PLIST( list, 8, INTOBJ_INT(firstDef) );2774SET_ELM_PLIST( list, 9, INTOBJ_INT(lastDef) );2775if ( treeType == 1 ) {2776SET_ELM_PLIST( list, 16, objExponent );2777}27782779/* clean out */2780CleanOut();27812782return INTOBJ_INT(nrdel);2783}278427852786/****************************************************************************2787**2788*F FuncStandardizeTable2C(<self>,<table>,<table2>,<stan>) . standardize ACT2789**2790** This is the kernel routine for standardizing an augmented coset table. It2791** is called by the GAP routine 'StandardizeTable2'. The user should not2792** call the kernel routine but only the GAP routine.2793**2794** If <stan> = 1 the table is standardized using the (old) semilenlex2795** standard.2796** If not <stan> = 1 the table is standardized using the (new) lenlex2797** standard (this is the default).2798*/2799Obj FuncStandardizeTable2C (2800Obj self,2801Obj list,2802Obj list2,2803Obj stan )2804{2805Obj * ptTable; /* pointer to table */2806Obj * ptTabl2; /* pointer to coset factor table */2807UInt nrgen; /* number of rows of the table / 2 */2808Obj * g; /* one generator list from table */2809Obj * h; /* generator list */2810Obj * i; /* and inverse */2811Obj * h2; /* corresponding factor lists */2812Obj * i2; /* and inverse */2813UInt acos; /* actual coset */2814UInt lcos; /* last seen coset */2815UInt mcos; /* */2816UInt c1, c2; /* coset temporaries */2817Obj tmp; /* temporary for swap */2818UInt j, k, nloop; /* loop variables */28192820/* get the arguments */2821objTable = list;2822if ( ! IS_PLIST(objTable) ) {2823ErrorQuit( "<table> must be a plain list (not a %s)",2824(Int)TNAM_OBJ(objTable), 0L );2825return 0;2826}2827ptTable = &(ELM_PLIST(objTable,1)) - 1;2828nrgen = LEN_PLIST(objTable) / 2;2829for ( j = 1; j <= nrgen*2; j++ ) {2830if ( ! IS_PLIST(ptTable[j]) ) {2831ErrorQuit(2832"<table>[%d] must be a plain list (not a %s)",2833(Int)j,2834(Int)TNAM_OBJ(ptTable[j]) );2835return 0;2836}2837}2838objTable2 = list2;2839if ( ! IS_PLIST(objTable2) ) {2840ErrorQuit( "<table2> must be a plain list (not a %s)",2841(Int)TNAM_OBJ(objTable), 0L );2842return 0;2843}2844ptTabl2 = &(ELM_PLIST(objTable2,1)) - 1;2845if ( IS_INTOBJ(stan) && INT_INTOBJ(stan) == 1 ) {2846/* use semilenlex standard */2847nloop = nrgen;2848}2849else {2850/* use lenlex standard */2851nloop = nrgen*2;2852}28532854/* run over all cosets */2855acos = 1;2856lcos = 1;2857while ( acos <= lcos ) {28582859/* scan through all columns of acos */2860for ( j = 1; j <= nloop; j++ ) {2861k = ( nloop == nrgen ) ? 2*j - 1 : j;2862g = &(ELM_PLIST(ptTable[k],1)) - 1;28632864/* if we haven't seen this coset yet */2865if ( lcos+1 < INT_INTOBJ( g[acos] ) ) {28662867/* swap rows lcos and g[acos] */2868lcos = lcos + 1;2869mcos = INT_INTOBJ( g[acos] );2870for ( k = 1; k <= nrgen; k++ ) {2871h = &(ELM_PLIST(ptTable[2*k-1],1)) - 1;2872i = &(ELM_PLIST(ptTable[2*k],1)) - 1;2873h2 = &(ELM_PLIST(ptTabl2[2*k-1],1)) - 1;2874i2 = &(ELM_PLIST(ptTabl2[2*k],1)) - 1;2875c1 = INT_INTOBJ( h[lcos] );2876c2 = INT_INTOBJ( h[mcos] );2877if ( c1 != 0 ) i[c1] = INTOBJ_INT( mcos );2878if ( c2 != 0 ) i[c2] = INTOBJ_INT( lcos );2879tmp = h[lcos];2880h[lcos] = h[mcos];2881h[mcos] = tmp;2882tmp = h2[lcos];2883h2[lcos] = h2[mcos];2884h2[mcos] = tmp;2885if ( i != h ) {2886c1 = INT_INTOBJ( i[lcos] );2887c2 = INT_INTOBJ( i[mcos] );2888if ( c1 != 0 ) h[c1] = INTOBJ_INT( mcos );2889if ( c2 != 0 ) h[c2] = INTOBJ_INT( lcos );2890tmp = i[lcos];2891i[lcos] = i[mcos];2892i[mcos] = tmp;2893tmp = i2[lcos];2894i2[lcos] = i2[mcos];2895i2[mcos] = tmp;2896}2897}28982899}29002901/* if this is already the next only bump lcos */2902else if ( lcos < INT_INTOBJ( g[acos] ) ) {2903lcos = lcos + 1;2904}29052906}29072908acos = acos + 1;2909}29102911/* shrink the tables */2912for ( j = 1; j <= nrgen; j++ ) {2913SET_LEN_PLIST( ptTable[2*j-1], lcos );2914SET_LEN_PLIST( ptTable[2*j ], lcos );2915SET_LEN_PLIST( ptTabl2[2*j-1], lcos );2916SET_LEN_PLIST( ptTabl2[2*j ], lcos );2917}29182919/* return void */2920return 0;2921}292229232924/****************************************************************************2925**2926*F FuncAddAbelianRelator( <hdCall> ) . . . . . . internal 'AddAbelianRelator'2927**2928** 'FuncAddAbelianRelator' implements 'AddAbelianRelator(<rels>,<number>)'2929*/2930Obj FuncAddAbelianRelator (2931Obj self,2932Obj rels, /* relators list */2933Obj number )2934{2935Obj * ptRels; /* pointer to relators list */2936Obj * pt1; /* pointer to a relator */2937Obj * pt2; /* pointer to another relator */2938Obj tmp;2939Int numcols; /* list length of the rel vectors */2940Int numrows; /* number of relators */2941Int i, j; /* loop variables */29422943/* check the arguments */2944if ( ! IS_PLIST(rels) ) {2945ErrorQuit( "<rels> must be a plain list (not a %s)",2946(Int)TNAM_OBJ(rels), 0L );2947return 0;2948}2949ptRels = &(ELM_PLIST(rels,1)) - 1;2950if ( TNUM_OBJ(number) != T_INT ) {2951ErrorQuit( "<number> must be a small integer (not a %s)",2952(Int)TNAM_OBJ(number), 0L );2953return 0;2954}29552956/* get the length of the given relators list */2957numrows = INT_INTOBJ(number);2958if ( numrows < 1 || LEN_PLIST(rels) < numrows ) {2959ErrorQuit( "inconsistent relator number", 0L, 0L );2960return 0;2961}2962tmp = ELM_PLIST( rels, numrows );2963if ( tmp == 0 ) {2964ErrorQuit( "inconsistent relator number", 0L, 0L );2965return 0;2966}2967pt2 = &(ELM_PLIST(tmp,1)) - 1;29682969/* get the length of the exponent vectors (the number of generators) */2970numcols = LEN_PLIST(tmp);29712972/* remove the last relator if it has length zero */2973for ( i = 1; i <= numcols; i++ ) {2974if ( INT_INTOBJ(pt2[i]) ) {2975break;2976}2977}2978if ( i > numcols ) {2979return INTOBJ_INT(numrows-1);2980}29812982/* invert the relator if its first non-zero exponent is negative */2983if ( INT_INTOBJ(pt2[i]) < 0 ) {2984for ( j = i; j <= numcols; j++ ) {2985pt2[j] = INTOBJ_INT( -INT_INTOBJ( pt2[j] ) );2986}2987}29882989/* if the last relator occurs twice, remove one of its occurrences */2990for ( i = 1; i < numrows; i++ ) {2991pt1 = &(ELM_PLIST(ptRels[i],1)) - 1;2992for ( j = 1; j <= numcols; j++ ) {2993if ( pt1[j] != pt2[j] ) {2994break;2995}2996}2997if ( j > numcols ) {2998break;2999}3000}3001if ( i < numrows ) {3002for ( i = 1; i <= numcols; i++ ) {3003pt2[i] = INTOBJ_INT(0);3004}3005numrows = numrows - 1;3006}30073008return INTOBJ_INT( numrows );3009}30103011/* new type functions that use different data structures */30123013UInt ret1,ret2;30143015UInt RelatorScan (3016Obj t,3017UInt di,3018Obj r )3019{3020UInt m,i,p,a,j;3021UInt pa=0,pb=0;3022UInt * rp;3023rp=(UInt*)ADDR_OBJ(r);3024m=rp[1]; /* length is in position 1 */3025i=2;3026p=di;3027while ((p!=0) && (i<=(m+1))){3028a=rp[i];3029pa=p;3030p=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,a),p));3031if (p!=0) i++;3032}30333034if (i>(m+1)) {3035if (p==di)3036return 1;3037else3038return 0;3039}30403041/* backwards scan */3042j=m+1;3043p=di;3044while ((p!=0) && (j>=i)) {3045/* a=INT_INTOBJ(ELM_PLIST(invtab,INT_INTOBJ(ELM_PLIST(r,j))));*/30463047a=rp[j];3048if ((a%2)==1)3049a++;3050else3051a--;3052pb=p;3053p=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,a),p));3054if (p!=0) j--;3055}30563057if (j<i) {3058if (p==pa)3059return 1;3060else3061return 0;3062}3063else {3064if (j==i) {3065a=rp[i];3066if ((a%2)==0) {3067p=a-1;3068ret1=pb;3069ret2=p;3070}3071else {3072p=a+1;3073ret1=pa;3074ret2=a;3075}3076SET_ELM_PLIST(ELM_PLIST(t,a),pa,INTOBJ_INT(pb));3077SET_ELM_PLIST(ELM_PLIST(t,p),pb,INTOBJ_INT(pa));30783079return 2;3080}3081else3082return 1;3083}30843085}30863087/* data object type for the mangled relators */3088Obj TYPE_LOWINDEX_DATA;30893090/****************************************************************************3091**3092*F FuncLOWINDEX_COSET_SCAN( <t>,<r>,<s1>,<s2>)3093**3094*/3095Obj FuncLOWINDEX_COSET_SCAN (3096Obj self,3097Obj t, /* table */3098Obj r, /* relators */3099Obj s1, /* stack */3100Obj s2 ) /* stack */3101{3102UInt ok,i,j,d,e,x,y,l,sd;3103Obj rx;3104UInt * s1a;3105UInt * s2a;31063107ok=1;3108j=1;3109/* we convert stack entries to c-integers to avoid conversion */3110sd=LEN_PLIST(s1);3111s1a=(UInt*)ADDR_OBJ(s1);3112s2a=(UInt*)ADDR_OBJ(s2);3113s1a[1]=INT_INTOBJ(s1a[1]);3114s2a[1]=INT_INTOBJ(s2a[1]);3115while ((ok==1) && (j>0)) {3116d=s1a[j];3117x=s2a[j];3118j--;3119rx=ELM_PLIST(r,x);3120l=LEN_PLIST(rx);3121i=1;3122while ((ok==1)&&(i<=l)) {3123ok=RelatorScan(t,d,ELM_PLIST(rx,i));3124if (ok==2) {3125j++;3126if (j>sd) {3127sd=2*sd;3128GROW_PLIST(s1,sd);3129SET_LEN_PLIST(s1,sd);3130CHANGED_BAG(s1);3131GROW_PLIST(s2,sd);3132SET_LEN_PLIST(s2,sd);3133CHANGED_BAG(s2);3134s1a=(UInt*)ADDR_OBJ(s1);3135s2a=(UInt*)ADDR_OBJ(s2);3136}3137s1a[j]=ret1;3138s2a[j]=ret2;3139ok=1;3140}3141i++;3142}31433144e=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,x),d));3145y=x+1;3146rx=ELM_PLIST(r,y);3147i=1;3148while ((ok==1)&&(i<=l)) {3149ok=RelatorScan(t,e,ELM_PLIST(rx,i));3150if (ok==2) {3151j++;3152if (j>sd) {3153sd=2*sd;3154GROW_PLIST(s1,sd);3155GROW_PLIST(s2,sd);3156s1a=(UInt*)ADDR_OBJ(s1);3157s2a=(UInt*)ADDR_OBJ(s2);3158}3159s1a[j]=ret1;3160s2a[j]=ret2;3161ok=1;3162}3163i++;3164}3165}3166/* clean up the mess we made */3167for (i=1;i<=sd;i++) {3168s1a[i]=(Int)INTOBJ_INT(0);3169s2a[i]=(Int)INTOBJ_INT(0);3170}3171if (ok==1)3172return True;3173else3174return False;3175}31763177/****************************************************************************3178**3179*F FuncLOWINDEX_IS_FIRST( <t>,<n>,<mu>,<nu>)3180**3181*/3182Obj FuncLOWINDEX_IS_FIRST (3183Obj self,3184Obj t, /* table */3185Obj nobj, /* relators */3186Obj muo, /* stack */3187Obj nuo ) /* stack */3188{3189UInt l,ok,b,g,ga,de,a,n,mm;3190UInt * mu;3191UInt * nu;31923193mm=LEN_PLIST(t)-1;3194n=INT_INTOBJ(nobj);3195mu=(UInt*)ADDR_OBJ(muo);3196nu=(UInt*)ADDR_OBJ(nuo);3197for (b=1;b<=n;nu[b++]=0);3198l=0;3199for (a=2;a<=n;a++) {3200for (b=1;b<=l;nu[mu[b++]]=0);3201mu[1]=a;3202nu[a]=1;3203l=1;3204ok=1;3205b=1;3206while ((ok==1) && (b<=n)) {3207g=1;3208while ((ok==1)&&(g<=mm)) {3209ga=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,g),b));3210de=INT_INTOBJ(ELM_PLIST(ELM_PLIST(t,g),mu[b]));3211if ((ga==0)||(de==0))3212ok=0;3213else {3214if (nu[de]==0) {3215l++;3216mu[l]=de;3217nu[de]=l;3218}3219if (nu[de]<ga)3220return False;3221else {3222if (nu[de]>ga) {3223ok=0;3224}3225}3226}3227g=g+2;3228}3229b=b+1;3230}3231}3232return True;3233}32343235/****************************************************************************3236**3237*F FuncLOWINDEX_PREPARE_RELS( <rels> )3238**3239*/3240Obj FuncLOWINDEX_PREPARE_RELS (3241Obj self,3242Obj r ) /* rels */3243{3244UInt i,j,k,l;3245Obj ri, rel;3246UInt * rp;32473248for (i=1;i<=LEN_PLIST(r);i++) {3249ri=ELM_PLIST(r,i);3250for (j=1;j<=LEN_PLIST(ri);j++) {3251rel=ELM_PLIST(ri,j); /* single relator */3252l=LEN_PLIST(rel);3253rp=(UInt*)ADDR_OBJ(rel);3254for (k=1;k<=l;k++)3255rp[k]=INT_INTOBJ(rp[k]); /* convert relator entries to C-integers */3256/* change type */3257TYPE_DATOBJ(rel) = TYPE_LOWINDEX_DATA;3258RetypeBag(rel,T_DATOBJ);32593260}3261}3262return (Obj) 0;3263}32643265/****************************************************************************3266**32673268*F * * * * * * * * * * * * * initialize package * * * * * * * * * * * * * * *3269*/32703271/****************************************************************************3272**32733274*V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export3275*/3276static StructGVarFunc GVarFuncs [] = {32773278{ "ApplyRel", 2, "app, relator",3279FuncApplyRel, "src/costab.c:ApplyRel" },32803281{ "MakeConsequences", 1, "list",3282FuncMakeConsequences, "src/costab.c:MakeConsequences" },32833284{ "MakeConsequencesPres", 1, "list",3285FuncMakeConsequencesPres, "src/costab.c:MakeConsequencesPres" },32863287{ "StandardizeTableC", 2, "table, standard",3288FuncStandardizeTableC, "src/costab.c:StandardizeTableC" },32893290{ "ApplyRel2", 3, "app, relators, nums",3291FuncApplyRel2, "src/costab.c:ApplyRel2" },32923293{ "CopyRel", 1, "relator",3294FuncCopyRel, "src/costab.c:CopyRel" },32953296{ "MakeCanonical", 1, "relator",3297FuncMakeCanonical, "src/costab.c:MakeCanonical" },32983299{ "TreeEntry", 2, "relator, word",3300FuncTreeEntry, "src/costab.c:TreeEntry" },33013302{ "MakeConsequences2", 1, "list",3303FuncMakeConsequences2, "src/costab.c:MakeConsequences2" },33043305{ "StandardizeTable2C", 3, "table, table, standard",3306FuncStandardizeTable2C, "src/costab.c:StandardizeTable2C" },33073308{ "AddAbelianRelator", 2, "rels, number",3309FuncAddAbelianRelator, "src/costab.c:AddAbelianRelator" },33103311{ "LOWINDEX_COSET_SCAN", 4, "table, relators, stack1,stack2",3312FuncLOWINDEX_COSET_SCAN, "src/costab.c:LOWINDEX_COSET_SCAN" },33133314{ "LOWINDEX_IS_FIRST", 4, "table, n, mu, nu",3315FuncLOWINDEX_IS_FIRST, "src/costab.c:LOWINDEX_IS_FIRST" },33163317{ "LOWINDEX_PREPARE_RELS", 1, "rels",3318FuncLOWINDEX_PREPARE_RELS, "src/costab.c:LOWINDEX_PREPARE_RELS" },33193320{ 0 }33213322};332333243325/****************************************************************************3326**33273328*F InitKernel( <module> ) . . . . . . . . initialise kernel data structures3329*/3330static Int InitKernel (3331StructInitInfo * module )3332{3333/* init filters and functions */3334InitHdlrFuncsFromTable( GVarFuncs );33353336/* import kind (and unkind) functions */3337ImportGVarFromLibrary( "TYPE_LOWINDEX_DATA",&TYPE_LOWINDEX_DATA );33383339/* static variables */3340InitGlobalBag( &objRel , "src/costab.c:objRel" );3341InitGlobalBag( &objNums , "src/costab.c:objNums" );3342InitGlobalBag( &objFactor , "src/costab.c:objFactor" );3343InitGlobalBag( &objTable , "src/costab.c:objTable" );3344InitGlobalBag( &objTable2 , "src/costab.c:objTable2" );3345InitGlobalBag( &objNext , "src/costab.c:objNext" );3346InitGlobalBag( &objPrev , "src/costab.c:objPrev" );3347InitGlobalBag( &objTree , "src/costab.c:objTree" );3348InitGlobalBag( &objTree1 , "src/costab.c:objTree1" );3349InitGlobalBag( &objTree2 , "src/costab.c:objTree2" );3350InitGlobalBag( &objWordValue, "src/costab.c:objWordValue" );3351InitGlobalBag( &objExponent , "src/costab.c:objExponent" );33523353/* return success */3354return 0;3355}335633573358/****************************************************************************3359**3360*F InitLibrary( <module> ) . . . . . . . initialise library data structures3361*/3362static Int InitLibrary (3363StructInitInfo * module )3364{3365/* init filters and functions */3366InitGVarFuncsFromTable( GVarFuncs );33673368/* return success */3369return 0;3370}337133723373/****************************************************************************3374**3375*F InitInfoCosetTable() . . . . . . . . . . . . . . table of init functions3376*/3377static StructInitInfo module = {3378MODULE_BUILTIN, /* type */3379"costab", /* name */33800, /* revision entry of c file */33810, /* revision entry of h file */33820, /* version */33830, /* crc */3384InitKernel, /* initKernel */3385InitLibrary, /* initLibrary */33860, /* checkInit */33870, /* preSave */33880, /* postSave */33890 /* postRestore */3390};33913392StructInitInfo * InitInfoCosetTable ( void )3393{3394return &module;3395}339633973398/****************************************************************************3399**34003401*E costab.c . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here3402*/340334043405